从一个复制块属性
标题栏。图纸你好我希望有人能够帮助我实现从一个标题栏到另一个标题栏的复制和粘贴属性。
我发现一个lisp在一定程度上可以工作，但有两个问题：
[列表=1]
[*]您无法从布局1中的块复制和粘贴到布局2。
[*]我们的块有一些重复的属性名称，例如3xTitle和2xSite
我附上了一张包含2个边框和lisp的dwg，以帮助解释。
我理解，每个边界内的重复属性可能需要克服，但我们有很多不同任务的边界，如果我们不必将属性名称更改为例如标题1、标题2、标题3等，那就太好了。。。
显然，如果这无法克服，但您可以跨各种布局复制属性，这本身就非常有利。
干杯
测验lsp 这可能会对你有所帮助，所以去看看吧，伙计。
(defun c:Action (/ ss ssObj ss1 ssObj1 ssTag1)
;;;; Tharwat 02. 03. 2011
(vl-load-com)
(if (eq (progn (initget "Copy Paste")
(setq ops (getkword "\n What to do :"))
)
"Copy"
)
(progn
(setq ss (car (nentsel "\n Select Block with Attributes: ")))
(setq ssObj (vlax-ename->vla-object ss))
(setq ssTag (vla-get-TextString ssObj))
)
(progn
(setq ss1 (car (nentsel "\n Select Block to change: ")))
(setq ssObj1 (vlax-ename->vla-object ss1))
(setq ssTag1 (vla-put-TextString ssObj1 ssTag))
)
)
(vla-regen (vla-get-activedocument (vlax-get-acad-object))
acActiveViewport
)
(princ)
)
Tharwat 嗨Tharwat
谢谢你的代码。然而，我似乎无法运行它。我已经使用APPLOAD加载了它，但是当我关闭APPLOAD窗口时，我在命令行上得到了“错误：输入列表格式错误”。
我试过输入“Action”，但它不起作用。我错过了一些简单的事情吗？ 嗨，Thorny，
很高兴在这里看到其他几个英国人
据我所知，您不能使用LISP手动选择不同布局中的块，因为在切换布局时，LISP会被取消。
然而，这提供了另一种方法，允许您选择一个块并更新具有相同名称的所有块（希望它也适用于具有相同名称的多个标记的块）。
使用“test”调用：
关于，
李 在VBA中几乎是一样的，它背后的原始想法是一个标题栏更改，无论有多少标题栏，额外的代码允许选择一个标识块名称的块，希望所有这些都有意义。只需运行add\u project\u number，它将与您的块一起工作，将DA1DRTXT更改为您的块名。
Public Sub add_project_number()
' This Updates the project number
Dim SS As AcadSelectionSet
Dim Count As Integer
Dim FilterDXFCode(1) As Integer
Dim FilterDXFVal(1) As Variant
Dim attribs, newtext As Variant
Dim BLOCK_NAME As String
'On Error Resume Next
Dim startCH As Double
newtext = ThisDrawing.Utility.GetString(True, "Enter new project code : ")
FilterDXFCode(0) = 0
FilterDXFVal(0) = "INSERT"
FilterDXFCode(1) = 2
FilterDXFVal(1) = "DA1DRTXT"
BLOCK_NAME = "DA1DRTXT"
Set SS = ThisDrawing.SelectionSets.Add("issued")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal
For Cntr = 0 To SS.Count - 1
attribs = SS.Item(Cntr).GetAttributes
attribs(1).TextString = newtext
attribs(1).Update
Next Cntr
ThisDrawing.SelectionSets.Item("issued").Delete
End Sub
和
Function Getpitname(Newpitname As String) As String
Dim PitNameSelect As AcadObject
Dim pitattribs As Variant
ThisDrawing.Utility.GetEntity PitNameSelect, basepnt, "pick pit name : "
If PitNameSelect.ObjectName = "AcDbText" Then
Getpitname = PitNameSelect.TextString
End If
If PitNameSelect.ObjectName = "AcDbBlockReference" Then
pitblname = PitNameSelect.Name ' RETURNS BLOCK NAME
pitattribs = PitNameSelect.GetAttributes
Getpitname = pitattribs(0).TextString
End If
End Function
您需要更改线newtext=ThisDrawing。公用事业GetString（True，“输入新项目代码：”）到
Dim PitNameSelect As AcadObject
ThisDrawing.Utility.GetEntity PitNameSelect, basepnt, "pick pit name : "
Newpitname = "1"'dummy to pass then return changed
pitname = Getpitname(Newpitname)
'Call Getpitname(pitname)
MsgBox "pitname selected is " & pitname
可以肯定的是，在将代码复制到Cad时，您错过了一个括号，我想这可能是最后一个括号了。
再试一次，祝你好运
塔瓦特 可能有兴趣。。。
http://www.cadtutor.net/forum/showthread.php?48397-复制所有属性。。。 谢谢你的回复。不幸的是，虽然您提供的Lisp本身就很好，但没有什么可以专门满足我们的需要。不太有效的一点是从一个块复制和粘贴属性到另一个块（使用不同的名称），同时切换布局。切换布局总是终止LISP。我发现最接近常规的是http://www.cadtutor.net/forum/showthread.php?48397-复制所有属性。谢谢alanjt。在lisp中是否有在布局之间切换的方法？或者有没有一种方法可以全局更新属性（即使块具有不同的名称），类似于ATTEDIT命令，但不必选择块？ 多刺的
Mine当前将更新相同名称的块，但您可以将其他块名称添加到过滤器：
5
红色显示的是选定块的名称，绿色显示的是要更新的其他块。
在我的应用程序中，当涉及到要更新的多个选择块时，您可以只键入“ALL”。当您不基于匹配的块名进行过滤时，这有点不稳定，如果有匹配的属性标记，则会更新。
页:
[1]
2