AutoCAD VBA程序---批量插入块源代码

Option Explicit

Private Sub cmdClear_Click()

  Me.lstFile.Clear

End Sub

Private Sub cmdDelete_Click()

    If lstFile.ListCount >= 1 Then

        If lstFile.ListIndex = -1 Then

            MsgBox "请选择列表中的图形名称！", vbExclamation, Me.Caption

            Exit Sub

        End If

        lstFile.RemoveItem (lstFile.ListIndex)

    End If

End Sub

Private Sub cmdInsert_Click()

  Dim i As Integer

  Dim pntX(0 To 2) As Double

  With Me

    pntX(0) = 0#: pntX(1) = 0#: pntX(2) = 0#

    If .lstFile.ListCount = 0 Then Exit Sub

    .pbInsert.Value = 0

    .pbInsert.Max = .lstFile.ListCount

    For i = 0 To .lstFile.ListCount - 1

        .lstFile.ListIndex = i

        ThisDrawing.Application.ActiveDocument.ModelSpace.InsertBlock pntX, .lstFile.List(i), 1, 1, 1, 0

        .pbInsert.Value = .pbInsert.Value + 1

    Next i

    MsgBox "批量插入块完毕。", vbInformation, .Caption

    Unload Me

  End With

End Sub

Private Sub cmdOpen_Click()

    Dim i As Integer

    Dim Y As Integer

    Dim Z As Integer

    Dim fileNames() As String

    On Error GoTo errHandle

    With comDlg

        .CancelError = True

        .MaxFileSize = 32767

        .Flags = cdlOFNHideReadOnly Or cdlOFNAllowMultiselect Or cdlOFNExplorer Or cdlOFNNoDereferenceLinks

        .DialogTitle = "选择图形文件"

        .filter = "图形文件(*.dwg)|*.dwg"

        .FileName = ""

        .ShowOpen

    End With

    comDlg.FileName = comDlg.FileName & Chr(0)

    Z = 1

    For i = 1 To Len(comDlg.FileName)

        i = InStr(Z, comDlg.FileName, Chr(0))

        If i = 0 Then Exit For

        ReDim Preserve fileNames(Y)

        fileNames(Y) = mID(comDlg.FileName, Z, i - Z)

        Z = i + 1

        Y = Y + 1

    Next i

    Dim count As Integer

    count = lstFile.ListCount

    If Y = 1 Then

        If Not HasItem(fileNames(Y - 1)) Then

            lstFile.AddItem fileNames(Y - 1), count

        End If

    Else

        For i = 1 To Y - 1

            If StrComp(Right$(fileNames(0), 1), "\") = 0 Then

                fileNames(i) = fileNames(0) & fileNames(i)

            Else

                fileNames(i) = fileNames(0) & "\" & fileNames(i)

            End If

            

            If Not HasItem(fileNames(i)) Then

                lstFile.AddItem fileNames(i), i - 1 + count

            End If

        Next i

    End If

errHandle:

End Sub

Private Sub lstFile_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

  On Error Resume Next

  MsgBox lstFile.List(lstFile.ListIndex), vbInformation, Me.Caption

End Sub

Private Function HasItem(ByVal strDwgName As String) As Boolean

    HasItem = False

    Dim i As Integer

    For i = 0 To lstFile.ListCount - 1

        If StrComp(lstFile.List(i), strDwgName, vbTextCompare) = 0 Then

            HasItem = True

            Exit Function

        End If

    Next i