在之间移动属性值

dbroada · 发表于 2022-7-6 09:23:37

我可能可以在VBA中很快完成这项工作，但今天需要绘制出来，所以我可能必须手动完成-除非有人能帮我快速完成一个脏兮兮的LISP。

基本上我有成对的块，一些有正确的信息，一些需要更改。我需要读取正确的信息，在此基础上创建一个新字符串，然后用新字符串填充另一个块，重写已有的内容。

所以
选择第一个块（名为“参考”）
读取“Ref”属性值（唯一属性）
选择第二个块（名为“CableNumber”）
用“LAN A”填充“Cable”属性

这些必须单独选择，而不是作为选择集。

如果有人愿意试一试，非常感谢。

Tharwat · 发表于 2022-7-6 09:31:14

如果我能很好地理解您的意思，这将从第一个选定的属性块中获得文本刺，并插入到第二个选定的属性块中。

但是：您应该直接选择字符串本身（点击字符串）。

祝你好运。

dbroada · 发表于 2022-7-6 09:34:13

谢谢塔瓦。我将有一个看了一会儿，但在此期间，我将使用下面的VBA一个我刚刚放在一起。

我不确定我会让它工作，所以我没有回来报告。我没有错误捕捉，所以它离理想状态很远。

我希望我没有浪费你太多时间。

copy

Option Explicit
Public Sub PickSourceItem()
Dim myAttributes As Variant
Dim myObject As AcadObject
Dim P1 As Variant
Dim myName As String
Dim myText As AcadText
Dim layerColl As AcadLayers
Dim CloudLayer As AcadLayer
On Error Resume Next
ThisDrawing.Utility.GetEntity myObject, P1, "Select Block"
If Err <> 0 Then
   Err.Clear
   MsgBox "No Object Selected"
   Exit Sub
End If
If myObject.EntityName = "AcDbBlockReference" Then
   myAttributes = myObject.GetAttributes
   myName = myAttributes(0).TextString & " LAN A"
   
ThisDrawing.Utility.GetEntity myObject, P1, "Select Block"
If myObject.EntityName = "AcDbBlockReference" Then
   myAttributes = myObject.GetAttributes
   myAttributes(0).TextString = myName
   End If
   
Else
   MsgBox "Block not selected"
End If
End Sub

Tharwat · 发表于 2022-7-6 09:36:45

不客气，布罗达。

我希望它能帮助你的工作，我希望有一天我会知道如何处理VBA例程。

当做

dbroada · 发表于 2022-7-6 09:40:17

好吧，两者都不完美。您的字符串不会创建第二个带有附加文本的字符串。如果我在选择过程中错过了第二个块，我会将修改后的字符串写回第一个块。

不过，我在绘图上有一个更大的问题。电报号码已经从3位数改为16个字符，我没有足够的空间，但至少我现在可以很快证明这一点。

Tharwat · 发表于 2022-7-6 09:44:14

没问题。

只需告诉我第二个选定属性块中的目标文本字符串将是什么。

我想这可能是必要的。

copy

(defun c:Test (/ ss1 ss2 e1 e2)
 (if
   (and
     (setq ss1 (nentsel "\n Select the first Attribute Block:"))
     (eq (cdr (assoc 0 (setq e1 (entget (car ss1))))) "ATTRIB")
     (setq ss2 (nentsel "\n Select the first Attribute Block:"))
     (eq (cdr (assoc 0 (setq e2 (entget (car ss2))))) "ATTRIB")
   )
    (vla-put-Textstring
      (vlax-ename->vla-object (car ss2))
      (strcat "Cable" " "(vla-get-Textstring (vlax-ename->vla-object (car ss1))) " " "LAN A")
    )
 )
 (princ)
)

dbroada · 发表于 2022-7-6 09:50:17

几乎

copy

       (strcat (vla-get-Textstring (vlax-ename->vla-object (car ss1))) " LAN A")

即可。

但是，

您是否能够修改它，以便我为第一个部分选择一段DTEXT而不是块，并将其放入第二个块的属性中（只选择一个块）。

我刚刚意识到我在这幅画上混合了方块和文字。

如果你愿意，非常感谢。

Tharwat · 发表于 2022-7-6 09:53:21

当然我会为你做的。

首先选择文本，然后在要替换的附件块中选择附件文本字符串。

撤消选项被添加到例程中。

copy

(defun c:Test (/ acdoc ss1 ss2 e1 e2)(vl-load-com)
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (vla-StartUndoMark acdoc)
 
 (if
   (and
     (setq ss1 (nentsel "\n Select Text to get its string:"))
     (eq (cdr (assoc 0 (setq e1 (entget (car ss1))))) "TEXT")
     (setq ss2 (nentsel "\n Select the first Attribute Block:"))
     (eq (cdr (assoc 0 (setq e2 (entget (car ss2))))) "ATTRIB")
   )
    (vla-put-Textstring
      (vlax-ename->vla-object (car ss2))
      (strcat
        (vla-get-Textstring (vlax-ename->vla-object (car ss1)))
      )
    )
 )
 
 (vla-EndUndoMark acdoc)
 
 (princ)
)

dbroada · 发表于 2022-7-6 09:58:20

太棒了-非常感谢。结合使用这两种程序，我今天有机会画出来。

Tharwat · 发表于 2022-7-6 10:01:56

不客气，布罗达。

我很高兴这套程序能满足你的需要。

祝你好运。

塔瓦特

[编程交流] 在之间移动属性值

发表回复

精选推荐