新浪博客

[转载]AutoCAD VBA程序---批量插入块源代码

2017-05-07 10:11阅读：

http://blog.sina.cn/dpool/blog/u/1866140464

原文地址：AutoCAD VBA程序---批量插入块源代码
原文作者：GIS广益

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

我的更多文章

下载客户端阅读体验更佳

APP专享