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

Question

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.
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?
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.
Thanks in advance
Georgia

Answer 1

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:
If you want to create a new Excel application:
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.

Answer 2

'Create new excel instance.
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