需要用autocad把VBA的值写入excel表格
我在Autocad中使用VBA来计算图纸中的块。 通过一些互联网search和一些尝试，我已经设法完成下面的代码，并在任何图纸，或图层或选定的所有块计数。
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表格和特定表单元格中。 有人能帮我find解决这个问题的办法吗？ 我不知何故设法称为Excel表，但我目前正在如何把块数放在正确的位置。 即让我们说，我希望他们在列表中，因为他们出现在我的代码中的计数表上，我怎么能实现呢？
PS我在这里是新的，如果你需要更多的信息，我会很乐意添加任何需要的信息，以find解决scheme。
先谢谢格鲁吉亚
我自己并不使用AutoCad VBA，但基于您的问题的简单性，我的猜测是，这可能会帮助您在路上：
如果你想创build一个新的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
您可以将这些值放在任何单元格或您想要的forms中; 这些是Excel VBA的基础知识。 另一种方法是首先在您的当前代码中加载BlockNumbers（然后填入数值）。 这样，您可以dynamic设置范围，并将数组中的所有数据同时加载到范围中。 我希望我没有误解你的问题，我的回答是符合你的目的的。
'创build新的Excel实例。 设置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