Question

我在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表，但我目前迷失了如何将块计数放在正确的位置。也就是说我想把它们放在一个列表中，因为它们出现在我从代码中得到的表中，我怎么能实现这个呢？

P.S。我是新来的，如果您需要更多信息，我很乐意添加所需的更多信息，以便找到解决方案。

提前致谢佐治亚

Answer 1

我自己不使用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（在当前代码中），然后填入值。这样，您可以动态设置范围，并立即将数组中的所有数据加载到范围中。我希望我没有误解你的问题，我的回复符合你的目的。

Answer 2

＆＃39;创建新的Excel实例。设置excelApp = CreateObject（＆＃34; Excel.Application＆＃34;）

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

需要将VBA中的值从autocad写入excel表

2 个答案: