我在Autocad中使用VBA来计算图形中的块。通过互联网进行一些搜索和一些尝试，我设法完成了以下代码并计算任何图形中的所有块，或按图层或所选块计算。
Sub BlockCount_Test()
dispBlockCount "COUNT_ALL"
dispBlockCount "COUNT_BY_LAYER"
dispBlockCount "COUNT_BY_FILTER"
End Sub
Sub dispBlockCount(ByVal strAction As String)
On Error Resume Next
Dim objBlkSet As AcadSelectionSet
Dim objBlkRef As AcadBlockReference
Dim strBlkNames() As String
Dim iGpCode(0) As Integer
Dim vDataVal(0) As Variant
Dim iSelMode As Integer
Dim iBlkCnt As Integer
iGpCode(0) = 0
vDataVal(0) = "INSERT"
iSelMode = 0 '|-- Selection Modes (0 = Select All, 1 = Select On Screen) --|
Set objBlkSet = getSelSet(iGpCode, vDataVal, iSelMode)
If objBlkSet.Count <> 0 Then
Select Case strAction
Case "COUNT_ALL"
ReDim strBlkNames(objBlkSet.Count - 1)
iBlkCnt = 0
For Each objBlkRef In objBlkSet
strBlkNames(iBlkCnt) = objBlkRef.Name
iBlkCnt = iBlkCnt + 1
Next
MsgBox getUniqBlockCount(strBlkNames), , "Count All"
Case "COUNT_BY_LAYER"
Dim objCadEnt As AcadEntity
Dim vBasePnt As Variant
ThisDrawing.Utility.GetEntity objCadEnt, vBasePnt, "Pick a block reference:"
If Err.Number <> 0 Then
MsgBox "No block references selected."
objBlkSet.Delete
Exit Sub
Else
If objCadEnt.ObjectName = "AcDbBlockReference" Then
Dim objCurBlkRef As AcadBlockReference
Dim strLyrName As String
iBlkCnt = 0
Set objCurBlkRef = objCadEnt
strLyrName = objCurBlkRef.Layer
For Each objBlkRef In objBlkSet
If StrComp(objBlkRef.Layer, strLyrName, vbTextCompare) = 0 Then
ReDim Preserve strBlkNames(iBlkCnt)
strBlkNames(iBlkCnt) = objBlkRef.Name
iBlkCnt = iBlkCnt + 1
End If
Next
MsgBox getUniqBlockCount(strBlkNames), , "Count by Layer"
Else
ThisDrawing.Utility.prompt "The selected object is not a block reference."
End If
End If
Case "COUNT_BY_FILTER"
Dim strFilter As String
iBlkCnt = 0
strFilter = ThisDrawing.Utility.GetString(False, "Enter a filter option:")
If strFilter <> "" Then
For Each objBlkRef In objBlkSet
If UCase(objBlkRef.Name) Like UCase(strFilter) Then
ReDim Preserve strBlkNames(iBlkCnt)
strBlkNames(iBlkCnt) = objBlkRef.Name
iBlkCnt = iBlkCnt + 1
End If
Next
MsgBox getUniqBlockCount(strBlkNames), , "Count by Filter"
Else
ThisDrawing.Utility.prompt "Search criteria should not be empty."
End If
Case Else
ThisDrawing.Utility.prompt "Invalid action mode."
End Select
Else
ThisDrawing.Utility.prompt "No block references were found."
End If
objBlkSet.Delete
If Err.Number <> 0 Then
ThisDrawing.Utility.prompt Err.Description
End If
End Sub
Function getSelSet(ByRef iGpCode() As Integer, vDataVal As Variant, iSelMode As Integer) As AcadSelectionSet
Dim objSSet As AcadSelectionSet
Set objSSet = ThisDrawing.SelectionSets.Add("EntSet")
Select Case iSelMode
Case 0
objSSet.Select acSelectionSetAll, , , iGpCode, vDataVal
Case 1
ReSelect:
objSSet.SelectOnScreen iGpCode, vDataVal
If objSSet.Count = 0 Then
Dim iURep As Integer
iURep = MsgBox("No entities selected, Do you want to select again?", _
vbYesNo, "Select Entity")
If iURep = 6 Then GoTo ReSelect
objSSet.Delete
Set getSelSet = Nothing
Exit Function
End If
Case Else
ThisDrawing.Utility.prompt "Invalid selection mode...."
End Select
Set getSelSet = objSSet
End Function
Function getUniqBlockCount(ByRef strBlkNames() As String) As String
Dim strUniqBlkNames() As String
Dim iBlkCount() As Integer
Dim iArIdx1, iArIdx2 As Integer
iArIdx1 = 0: iArIdx2 = 0
For iArIdx1 = LBound(strBlkNames) To UBound(strBlkNames)
If iArIdx1 = 0 Then
ReDim strUniqBlkNames(iArIdx2)
strUniqBlkNames(iArIdx2) = strBlkNames(iArIdx1)
iArIdx2 = iArIdx2 + 1
End If
Dim iUnqArIdx As Integer
Dim blUniq As Boolean
blUniq = True
For iUnqArIdx = LBound(strUniqBlkNames) To UBound(strUniqBlkNames)
If StrComp(strBlkNames(iArIdx1), strUniqBlkNames(iUnqArIdx), vbTextCompare) = 0 Then
blUniq = False
Exit For
End If
Next
If blUniq Then
ReDim Preserve strUniqBlkNames(iArIdx2)
strUniqBlkNames(iArIdx2) = strBlkNames(iArIdx1)
iArIdx2 = iArIdx2 + 1
End If
Next
iArIdx1 = 0: iArIdx2 = 0
For iArIdx1 = LBound(strUniqBlkNames) To UBound(strUniqBlkNames)
For iArIdx2 = LBound(strBlkNames) To UBound(strBlkNames)
If StrComp(strBlkNames(iArIdx2), strUniqBlkNames(iArIdx1), vbTextCompare) = 0 Then
ReDim Preserve iBlkCount(iArIdx1)
iBlkCount(iArIdx1) = iBlkCount(iArIdx1) + 1
End If
Next
Next
For iUnqArIdx = LBound(iBlkCount) To UBound(iBlkCount)
strUniqBlkNames(iUnqArIdx) = strUniqBlkNames(iUnqArIdx) & vbTab & vbTab & vbTab & iBlkCount(iUnqArIdx) & vbCrLf
Next
Dim strTitle, strBlkCount As String
strBlkCount = Join(strUniqBlkNames)
strTitle = "Block Name" & vbTab & vbTab & "Count" & vbCrLf
strTitle = strTitle & String(14, "-") & vbTab & vbTab & String(8, "-") & vbCrLf
getUniqBlockCount = strTitle & strBlkCount
End Function
我的目标是获取这些块号并自动将它们插入 excel 工作表以及某个工作表和单元格中。有人可以帮助我找到解决此问题的方法吗？我不知何故设法调用了一个 excel 表，但我目前不知道如何将块计数放在正确的位置。即假设我希望它们出现在我从代码中的计数中获得的表格中一样，我希望它们出现在列表中，我如何实现这一点？
附言我是新来的，如果您需要更多信息，我很乐意添加更多信息以找到解决方案。
提前致谢格鲁吉亚
我自己不使用AutoCad VBA，但基于您问题的简单性质，我的猜测是这可能会在旅途中为您提供帮助：
如果要创建新的 Excel 应用程序：
Dim oApp_Excel as Excel.Application
Dim oBook as Excel.workbook
Set oApp_Excel = CreateObject("EXCEL.APPLICATION")
set oBook = oApp_Excel.workbooks.add
oBook.sheets("<Name>").cells(<Counter>, <Column_Number>).value = <BlockNr (based on counter)>
oBook.SaveAs(<Path>)
oBook.close
oApp_Excel.quit
set oBook = nothing
您可以将值放在所需的任何单元格或表单中;这些是Excel VBA的基础知识。另一种方法是先在数组中加载 BlockNumbers（在当前代码中），然后填写值。这样，您可以动态设置范围，并一次将数组中的所有数据加载到该范围内。我希望我没有误解你的问题，我的回答符合你的目的。
'创建新的 excel 实例。 Set excelApp = CreateObject（"Excel.Application"）
If err <> 0 Then
MsgBox "Could not start Excel!", vbExclamation, "Warning"
End
Else
excelApp.Visible = True
excelApp.ScreenUpdating = False
'Add a new workbook and set the objects.
Set wkbObj = excelApp.Workbooks.Add(1)
Set shtObj = excelApp.Worksheets(1)
shtObj.Name = "Measured Polylines"
With shtObj.Range("A1:D1")
.Font.Bold = True
.Autofilter
End With