[编程交流] 从一个复制块属性

(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,Paste]:"))
         )
         "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)
)

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

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

5