需要使用 VBA 将值从 autocad 写入 Excel 表

Need to write values with VBA from autocad into an excel sheet

提问by Georgia

I am using VBA in Autocad in order to count blocks in drawings. With some search through the internet and some tries I have managed to complete the following code and count all blocks in any drawing, or by layer or the selected ones.

我在 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

My aim is to take these block numbers and insert them automatically in an excel sheet and in a certain sheet and cells. Can someone help me find a solution to this problem? I somehow managed to call an excel sheet but I am currently lost on how to put the block counts in the right position. i.e. Let's say that I want them in a list as they present on the table I get from the count in my code, how could I achieve this?

我的目标是获取这些块号并将它们自动插入到 Excel 工作表以及某个工作表和单元格中。有人可以帮我找到解决这个问题的方法吗？我以某种方式设法调用了一个 excel 表，但我目前不知道如何将块计数放在正确的位置。即假设我希望它们在列表中显示在我从代码中的计数中获得的表格中，我怎么能做到这一点？

P.S. I am new here and if you need any more info I would gladly add any more information needed in order to find a solution.

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

Thanks in advance Georgia

提前致谢 格鲁吉亚

回答by Trace

I don't use AutoCad VBA myself, but based on the simple nature of your question, my guess is that this may help you on the road:

我自己不使用 AutoCad VBA，但根据您问题的简单性质，我的猜测是这可能对您有所帮助：

If you want to create a new Excel application:

如果要创建新的 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 

You can place the values in any cell or form you want; these are the basics of Excel VBA. Another way is to load you BlockNumbers in an array first (in your current code) and then filling in values. This way you can set a range dynamically and load all the data from the array into the range at once. I hope that I didn't misunderstand your question and that my reply serves your purpose.

您可以将值放置在您想要的任何单元格或表单中；这些是 Excel VBA 的基础知识。另一种方法是首先将 BlockNumbers 加载到数组中（在您当前的代码中），然后填充值。通过这种方式，您可以动态设置范围并将数组中的所有数据一次加载到范围中。我希望我没有误解你的问题，我的回答符合你的目的。

回答by Evord

'Create new excel instance. Set excelApp = CreateObject("Excel.Application")

'创建新的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