圖塊的數量檢視與修改名稱

'自訂表單 Userform 最少需要 Listbox1、TextBox1、TextBox2、CommandButton1、CommandButton2、Label3 等控制項 Option Explicit Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private BlksName() As String Private cadobj As AcadEntity '修改圖塊名稱，並重讀圖面內的所有圖塊名稱 Private Sub CommandButton1_Click()     On Error GoTo 1     ThisDrawing.Blocks(TextBox1.Text).Name = TextBox2.Text     On Error GoTo 0     ListBox1.Clear     GetAllBlocks     TextBox1.Text = ""     TextBox2.Text = ""     Exit Sub 1:     MsgBox Err.Description     Err.Clear End Sub '結束表單 Private Sub CommandButton2_Click()     If Not cadobj Is Nothing Then cadobj.Highlight False     Unload Me End Sub '檢視與計算選擇的圖塊 Private Sub ListBox1_Click()     TextBox1.Text = ListBox1.Text     ZoomAll     ''''''建立選擇集並選擇圖面上的所有元件''''''''''     Dim FilterSet As AcadSelectionSet     On Error Resume Next     ThisDrawing.SelectionSets("xxx").Delete     On Error GoTo 0     Set FilterSet = ThisDrawing.SelectionSets.Add("xxx")     '設定選擇集的過濾條件     Dim FilterType(0) As Integer     Dim FilterData(0) As Variant     FilterType(0) = 2     FilterData(0) = ListBox1.Text     '選擇圖面上的所有元件     FilterSet.Select acSelectionSetAll, , , FilterType, FilterData     Label3.Caption = "名稱：" & ListBox1.Text & Chr(13) & _         "總數：" & FilterSet.Count & " 個"     '沒有任何元件時直接離開巨集     If FilterSet.Count = 0 Then         Set FilterSet = Nothing         Exit Sub     End If     If Not cadobj Is Nothing Then cadobj.Highlight False     Set cadobj = FilterSet.Item(0)     cadobj.Highlight True     Dim minExt As Variant     Dim maxExt As Variant     On Error GoTo 1     cadobj.GetBoundingBox minExt, maxExt     ZoomWindow minExt, maxExt     Dim i As Integer     For i = 10 To 5 Step -1         ZoomScaled scale:=i * 0.1, scaletype:=acZoomScaledRelative         Sleep 50     Next i 1: End Sub Private Sub UserForm_Initialize()     Me.Caption = "圖塊名稱修改 --- WenHe"     Label3.Caption = "請選擇圖塊名稱。"     GetAllBlocks End Sub '讀取圖面內所有的圖塊名稱 Private Sub GetAllBlocks()     Dim blk As AcadBlock     Dim k As Integer     ReDim BlksName(0) As String     k = 0     For Each blk In ThisDrawing.Blocks         If Left(blk.Name, 1) <> "*" Then             ReDim Preserve BlksName(0 To k) As String             BlksName(k) = blk.Name             k = k + 1         End If     Next     SortStringArray BlksName     ListBox1.List() = BlksName End Sub ''''''''''排序字串陣列，限一維陣列、限陣列內資料不重複 Private Sub SortStringArray(ByRef strarray() As String)     Dim strarray2() As String     Dim i As Integer, j As Integer     Dim k As Integer     strarray2 = strarray     For i = 0 To UBound(strarray2)         k = 0         For j = 0 To UBound(strarray2)             If i <> j Then                 k = k + IIf(StrComp(strarray2(i), strarray2(j)) > 0, 1, 0)             End If         Next j         strarray(k) = strarray2(i)     Next i End Sub