在selec中循环通过区块

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

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

通过一次选择一个块来工作的代码是

copy


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

copy


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

copy


  
  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

copy


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的块

copy


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中循环通过区块

发表回复

精选推荐