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

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

Posted by: admin May 14, 2020 Leave a comment

Questions:

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

How to&Answers:

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:

‘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