社区 › Auto Lisp › 在selec中循环通过区块

comcu 发表于 2022-7-6 17:22:11

在selec中循环通过区块

嗨，我希望有人能给我解释一下。我（在这个论坛的很多帮助下）编写了一些代码，允许选择具有属性的块，保存某些属性值，代码然后删除块，然后允许用户在图形上选择一个点以插入新块。然后将旧块中的值转移到新块。然后，用户转到下一个块并再次执行该过程。我想做的是更改代码，以便在运行代码时，使autocad选择具有特定名称的每个块，并将每个块的属性保存在阵列中，然后将新块插入到与旧块相同的插入点。
我认为我已经实现了很多这些功能。我需要添加的唯一一件事是，块选择具有特定名称的所有块，然后设置一个数组来执行I=cnt（cnt是所选块的顶部数量），然后循环遍历我现有的代码，唯一的更改是插入点从允许用户选择更改为获取旧的块插入指向并在同一点中插入名称块。
 
通过一次选择一个块来工作的代码是
 

Public Sub BRPT1_StorAttValues()

   Dim MyBlockRef As AcadBlockReference
   Dim myvaratt As Variant
   Dim i As Double
   Dim MyoEnt As AcadEntity
   Dim MyBlockObj As AcadBlock
   Dim OLD_BLOCK_NAME As String
   Dim NEW_BLOCK_NAME As String
   'Dim MyAttTextStr As String
   
   MyAttTextStr_Old_1 = "ROOM_NUMBER"
   MyAttTextStr_Old_2 = "HEIGHT"
   MyAttTextStr_Old_3 = "COMMENT"
   
NEW_BLOCK_NAME = "LEVEL4_ATTBLOCK"   ''''change 'the text to current 'new block name'


   On Error Resume Next
   ThisDrawing.SelectionSets("SelectBlock").Delete
   If Err Then Err.Clear
   With ThisDrawing.Utility
       '' create a new selectionset
       Set MyOldBlockObjSS = ThisDrawing.SelectionSets.Add("SelectBlock")

       '' let user select entities interactively
       MyOldBlockObjSS.SelectOnScreen

      'MyObjSS.SelectOnScreen FilterType, FilterData
      'MyObjSS.Select acSelectionSetAll 'FilterType, FilterData
       '' highlight the selected entities
       MyOldBlockObjSS.Highlight True
      
       '' pause for the user
       .prompt vbCr & MyOldBlockObjSS.Count & " entities selected"
       '.GetString False, vbLf & "Enter to continue "

       For Each MyoEnt In MyOldBlockObjSS
         If TypeOf MyoEnt Is AcadBlockReference Then
               Set MyBlockRef = MyoEnt
               myvaratt = MyBlockRef.GetAttributes
               For i = 0 To UBound(myvaratt)
                   If myvaratt(i).TagString = MyAttTextStr_Old_1 Then
                     'myvaratt(i).TextString = "Test"
                     MyAttTextStr1 = myvaratt(i).TextString
                           myvaratt(i).Update
                        
                   End If
               Next
         End If
       Next
'End With

       For Each MyoEnt In MyOldBlockObjSS
         If TypeOf MyoEnt Is AcadBlockReference Then
               Set MyBlockRef = MyoEnt
               myvaratt = MyBlockRef.GetAttributes
               For i = 0 To UBound(myvaratt)
                   If myvaratt(i).TagString = MyAttTextStr_Old_2 Then
                     'myvaratt(i).TextString = "Test"
                     MyAttTextStr2 = myvaratt(i).TextString
                           myvaratt(i).Update
                           
                        
                   End If
               Next
         End If
       Next
'End With

       For Each MyoEnt In MyOldBlockObjSS
         If TypeOf MyoEnt Is AcadBlockReference Then
               Set MyBlockRef = MyoEnt
               myvaratt = MyBlockRef.GetAttributes
               For i = 0 To UBound(myvaratt)
                   If myvaratt(i).TagString = MyAttTextStr_Old_3 Then
                     'myvaratt(i).TextString = "Test"
                     MyAttTextStr3 = myvaratt(i).TextString
                           myvaratt(i).Update
                           
                        
                   End If
               Next
         End If
       Next
End With


MyAttTextStr1 = Right$(MyAttTextStr1, 3)
   MyAttTextStr2 = Right$(MyAttTextStr2, 4)
   
         MyAttTextStr2 = MyAttTextStr2 / 1000#


MyAttTextStr2 = Round(MyAttTextStr2, 2#)


                  ' DO NOT DELETE KEEP FOR CHECKING
                  ' MsgBox (MyAttTextStr1)
                   'MsgBox (MyAttTextStr2)
                  ' MsgBox (MyAttTextStr3)
   

   
                           MyOldBlockObjSS.Erase
                           
      BRPT2_InsertingBlockWithNewValues
      
End Sub




Sub BRPT2_InsertingBlockWithNewValues()

   ' Define the block
'Dim MyAttTextStr As String
   Dim blockObj As AcadBlock
   Dim insertionPnt(0 To 2) As Double
   insertionPnt(0) = 0
   insertionPnt(1) = 0
   insertionPnt(2) = 0
   'Set blockObj = ThisDrawing.Blocks.Add _
                  '(insertionPnt, "LEVEL4_ATTBLOCK")
                     '(insertionPnt, "APA013")

Dim MyInsertPt As Variant
MyInsertPt = ThisDrawing.Utility.GetPoint(, vbCr & "Pick insertion point: ")

   ' Insert the block
   Dim blockrefobj As AcadBlockReference
   
   Myblockrefobj = "LEVEL4_ATTBLOCK"
   'Myblockrefobj = "APA013"
   
                   Set blockrefobj = ThisDrawing.ModelSpace.InsertBlock _
               (MyInsertPt, Myblockrefobj, 1#, 1#, 1#, 0)
   'ZoomAll
' MsgBox "Block Has Been Inserted " & blockrefobj.ObjectName
   
   
   BRPT3_InsertStordValueInToNewBlock
   
End Sub






Sub BRPT3_InsertStordValueInToNewBlock()

   
   
   Dim MyBlockRef As AcadBlockReference
   Dim MyObjSS As AcadSelectionSet
   Dim myvaratt As Variant
   Dim i As Double
   Dim MyoEnt As AcadEntity
   Dim MyBlockObj As AcadBlock
   Dim OLD_BLOCK_NAME As String
   Dim NEW_BLOCK_NAME As String


      MyAttTextStr_NEW_1 = "ROOM_REF"
   MyAttTextStr_NEW_2 = "ROOM_CEILING_HEIGHT"
   MyAttTextStr_NEW_3 = "ROOM_DESC"


   
NEW_BLOCK_NAME = "LEVEL4_ATTBLOCK"   ''''change 'the text to current 'new block name'

'MyAttTextStr = "Test 1"


   On Error Resume Next
   ThisDrawing.SelectionSets("SelectBlock").Delete
   If Err Then Err.Clear
   With ThisDrawing.Utility
       '' create a new selectionset
       Set MyObjSS = ThisDrawing.SelectionSets.Add("SelectBlock")

       '' let user select entities interactively
       'MyObjSS.SelectOnScreen
       MyObjSS.Select acSelectionSetLast

      'MyObjSS.SelectOnScreen FilterType, FilterData
      'MyObjSS.Select acSelectionSetAll 'FilterType, FilterData
       '' highlight the selected entities
       MyObjSS.Highlight True
      
       '' pause for the user
       .prompt vbCr & MyObjSS.Count & " entities selected"
       '.GetString False, vbLf & "Enter to continue "
'-----------------------------------------------------------------------------
       For Each MyoEnt In MyObjSS
         If TypeOf MyoEnt Is AcadBlockReference Then
               Set MyBlockRef = MyoEnt
               myvaratt = MyBlockRef.GetAttributes
               For i = 0 To UBound(myvaratt)
                   If myvaratt(i).TagString = MyAttTextStr_NEW_1 Then

                     myvaratt(i).TextString = MyAttTextStr1
                     
                               End If
               Next
         End If
       Next
                     
'-----------------------------------------------------------------------------
          For Each MyoEnt In MyObjSS
         If TypeOf MyoEnt Is AcadBlockReference Then
               Set MyBlockRef = MyoEnt
               myvaratt = MyBlockRef.GetAttributes
               For i = 0 To UBound(myvaratt)
               
                   If myvaratt(i).TagString = MyAttTextStr_NEW_2 Then
                  
                  
                     myvaratt(i).TextString = MyAttTextStr2
                     
                  

                  
                                    myvaratt(i).Update
                                    
                           
                               End If
               Next
         End If
       Next


'-----------------------------------------------------------------------------
                        For Each MyoEnt In MyObjSS
         If TypeOf MyoEnt Is AcadBlockReference Then
               Set MyBlockRef = MyoEnt
               myvaratt = MyBlockRef.GetAttributes
               For i = 0 To UBound(myvaratt)
               
               If myvaratt(i).TagString = MyAttTextStr_NEW_3 Then

                     myvaratt(i).TextString = MyAttTextStr3
                     
               End If
               Next
         End If
       Next
End With

   
End Sub




Public MyAttTagStr_Old_1 As String
Public MyAttTagStr_Old_2 As String
Public MyAttTagStr_Old_3 As String

Public MyAttTagStr_NEW_1 As String
Public MyAttTagStr_NEW_2 As String
Public MyAttTagStr_NEW_3 As String

Public MyAttTextStr1 As String
Public MyAttTextStr2 As String
Public MyAttTextStr3 As String

Public MyOldBlockObjSS As AcadSelectionSet

comcu 发表于 2022-7-6 19:19:56

那是我的旧密码。我现在开始尝试用以下内容修改它，下面的模块选择所有名为APA013的块

Sub selectBlock()

Dim FilterType(0) As Integer
Dim FilterData(0) As Variant

      On Error Resume Next
   ThisDrawing.SelectionSets("SelectBlock").Delete
   If Err Then Err.Clear
   With ThisDrawing.Utility
       '' create a new selectionset
Set objSS = ThisDrawing.SelectionSets.Add("SelectBlock")

FilterType(0) = 2
FilterData(0) = "APA013"

objSS.Select acSelectionSetAll, , , FilterType, FilterData

       objSS.Highlight True
         blkcnt = objSS.Count
            'objSS.Highlight False
               'objSS.Delete
         
          End With
         
         StorAttValues
         
End Sub


从那里我不知道如何使代码循环通过每个块，然后再开始代码？
 
谢谢你的帮助，
 
col公司

查看完整版本: 在selec中循环通过区块