Code to go‎ > ‎

VBA Snippets for Autocad

This page hosts a number of snippets regarding VBA and, more specifically, VBA as used with Autocad. The test machine has an Autocad 2007 installed but most of the code should work with other versions. If / when someone reports pices of code that do not work with certain versions the snippets will be updated accordingly.

Also, note that I'm not the author of all the code inhere. Some parts were copied and, despite my best intention, the sources were lost. If someone finds that he / she is the author I will be more than happy to add a mention on the right side.

Some great places to learn about VBA and, specifically, VBA with Autocad, are listed below:
At the bottom of this page are listed links to some modules that are too large to be placed here, so they have a page each.

 The code Description
Private Declare Function _
    GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
    
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type


Public Function ShowOpen(Filter As String, _
    InitialDir As String, _
    DialogTitle As String) As String

    Dim OFName As OPENFILENAME

    'Set the structure size
    OFName.lStructSize = Len(OFName)
    'Set the owner window
    OFName.hwndOwner = 0
    'Set the filter
    OFName.lpstrFilter = Filter
    'Set the maximum number of chars
    OFName.nMaxFile = 255
    'Create a buffer
    OFName.lpstrFile = Space(254)
    
    'Create a buffer
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    OFName.lpstrInitialDir = InitialDir
    'Set the dialog title
    OFName.lpstrTitle = DialogTitle
    'no extra flags
    OFName.flags = 0
    'Show the 'Open File' dialog
    If GetOpenFileName(OFName) Then
        ShowOpen = Trim(OFName.lpstrFile)
    Else
        ShowOpen = ""
    End If
End Function
 Asks the user for a file name using standard Windows dialog.
Public Function Atn2( _
        ByVal y As Double, _
        ByVal x As Double) As Double
        
    On Error GoTo DivideError
    Atn2 = Atn(y / x)
    If (x < 0) Then
        If (y < 0) Then
            Atn2 = Atn2 - vbPI
        Else
            Atn2 = Atn2 + vbPI
        End If
    End If
    Exit Function
    
DivideError:
    If Abs(y) > Abs(x) Then   'Must be an overflow
        If y > 0 Then
            Atn2 = vbPI / 2
        Else
            Atn2 = -vbPI / 2
        End If
    Else
        Atn2 = 0   'Must be an underflow
    End If
    Resume Next
    
End Function
 Math only has Atn. Here is Atn2.
Private Sub append(ByRef the_array, ByRef the_val)

    On Error GoTo empty_array
    
    ReDim Preserve the_array( _
        LBound(the_array) To _
        UBound(the_array) + 1)
    the_array(UBound(the_array)) = the_val
    Exit Sub
    
empty_array:
    ReDim the_array(0 To 0)
    the_array(0) = the_val
End Sub

Private Sub test_append()
    
    Dim ary() As String
    
    ReDim ary(0 To 2)
    ary(1) = "0"
    ary(1) = "1"
    ary(2) = "2"
    Call append(ary, "3")
    Call append(ary, "4")
    
    ReDim ary(1 To 2)
    ary(1) = "1"
    ary(2) = "2"
    Call append(ary, "3")
    Call append(ary, "4")
    
End Sub 
 This is how a value can be easily appended to an array. A test routine is also presented to show the usage.
Private Sub IterateInObjects()

    Dim iter_obj As AcadObject
    Dim ThePoly As AcadLWPolyline
    Dim s_lay_filt As String
    
    ' may be used as argument
    s_lay_filt = "0"
    
    ' iterate in each and every object in model
    For Each iter_obj In ThisDrawing.ModelSpace
        
        ' check the type of the object
        If (TypeOf iter_obj Is AcadLWPolyline) Then
            
            ' cast to appropriate type
            Set ThePoly = iter_obj
            
            ' check the layer
            If (ThePoly.Layer = s_lay_filt) Then
                
                ' do something with this object
                Debug.Print "Area is " & ThePoly.area
            End If
        End If
    Next iter_obj

End Sub
 This snippet simply shows how the components of a block or model or paper (these are also blocks) can be iterated and filtered without using filters.
Private Sub IterateWithSelSet()
    
    Dim iter_obj As AcadObject
    Dim ss As AcadSelectionSet
    Dim FilterType(1) As Integer
    Dim FilterData(1) As Variant
    Dim ThePoly As AcadLWPolyline
    Dim s_lay_filt As String
    
    ' may be used as argument
    s_lay_filt = "0"
    
    
    ' create a new selection set
    ' may fail if the name is already added
    Set ss = ThisDrawing.SelectionSets. _
        Add("SelectionSet10")
    
    ' set-up filters
    
    '0 - Indicates filter refers to an object type
    ' this is a A DXF group code
    FilterType(0) = 0
    'Indicates the object type is a 2D polyline
    FilterData(0) = "LWPolyline"
    
    '8 - Indicates a filter that refers to a layer
    ' this is a A DXF group code
    FilterType(1) = 8
    'The objects must reside on this layer
    FilterData(1) = s_lay_filt
    
    ' perform selection
    ss.Select acSelectionSetAll, , , FilterType, FilterData
    If (ss.Count = 0) Then
        MsgBox "No polyline in selected layer"
    Else
        ' iterate in each and every object in model
        For Each iter_obj In ss
            ' cast to appropriate type
            Set ThePoly = iter_obj
            
            ' do something with this object
            Debug.Print "Area is " & ThePoly.area
        Next
    End If
    
    ' we no longer need this selection set
    ss.Delete
    
End Sub
 Just as the snippet above, this iterates n all polylines in model but uses selection sets and filters to achieve this goal. The codes used in FilterType are DXF group codes.  This has the advantage that looks simpler when used with multiple criteria.
Private Sub StraightPoly()

    Dim bSel As Boolean
    Dim sPick As Variant
    Dim retObj As AcadObject
    Dim ThePoly As AcadLWPolyline
    Dim i As Integer, j As Integer, k As Integer
    Dim alfa1 As Double, alfa2 As Double, dst As Double
    Dim ptsToDel As Integer
    Dim ptd() As Integer
    Dim ptnew() As Double
    Dim bigCounter As Integer


    bigCounter = 0

Resume_Poly:

    ' Ask the user to select a polyline
    bSel = False
    On Error GoTo Err_Hdl_sel
    While (bSel = False)
        ThisDrawing.Utility.GetEntity _
            retObj, sPick, "Select polyline"
            
        If (TypeOf retObj Is AcadLWPolyline = False) Then
            ThisDrawing.Utility.Prompt _
                ("The object is not a polyline (" & _
                    retObj.ObjectName & ")!")
        Else
            bSel = True
        End If
    Wend
    Set ThePoly = retObj
    On Error GoTo 0


    ' now go straight it up
    Do
        ReDim ptd(0 To UBound(ThePoly.Coordinates))
        ptsToDel = 0
        i = 0
        j = 4
        k = 2
        While (j <= UBound(ThePoly.Coordinates))
            alfa1 = Atn2(ThePoly.Coordinates(j + 1) - _
                            ThePoly.Coordinates(i + 1), _
                            ThePoly.Coordinates(j + 0) - _
                            ThePoly.Coordinates(i + 0))
            alfa2 = Atn2(ThePoly.Coordinates(k + 1) - _
                            ThePoly.Coordinates(i + 1), _
                            ThePoly.Coordinates(k + 0) - _
                            ThePoly.Coordinates(i + 0))
            dst = Math.Sqr((ThePoly.Coordinates(k + 1) - _
                            ThePoly.Coordinates(i + 1)) ^ 2 + _
                           (ThePoly.Coordinates(k + 0) - _
                           ThePoly.Coordinates(i + 0)) ^ 2)
            alfa1 = Math.Abs(alfa1 - alfa2)
            If (alfa1 < 0.0001) Then
                If (Math.Tan(alfa1) * dst < 0.001) Then
                    '// point k should be removed
                    ptd(ptsToDel) = k
                    ptsToDel = ptsToDel + 1
                End If
            End If
            i = i + 2
            k = k + 2
            j = j + 2
        Wend
        
        If (ptsToDel > 0) Then
            i = (UBound(ThePoly.Coordinates) + 1) / 2 - ptsToDel
            i = i * 2 - 1
            ReDim ptnew(0 To i)
            k = 0
            For i = 0 To UBound(ThePoly.Coordinates) Step 2
                For j = 0 To ptsToDel - 1
                    If (ptd(j) = i) Then
                        GoTo Netx__i
                    End If
                Next j
                ptnew(k + 0) = ThePoly.Coordinates(i + 0)
                ptnew(k + 1) = ThePoly.Coordinates(i + 1)
                k = k + 2
Netx__i:
            Next i
            ThePoly.Coordinates = ptnew
            bigCounter = bigCounter + ptsToDel
        End If
    Loop Until ptsToDel = 0
    
    Call ThisDrawing.Utility.Prompt(vbNewLine & _
        "A number of " & CStr(bigCounter) & _
        " points were removed from the polyline" & _
        vbNewLine)
        
Function_End:

    Exit Sub
    
'  ----------------------------------------------------------
Err_Hdl_sel:
    Call ThisDrawing.Utility.InitializeUserInput( _
        0, "Y N")
    If (ThisDrawing.Utility.GetKeyword( _
        "Quit? Y/<N>") = "Y") Then
        Resume Function_End
    Else
        Resume Resume_Poly
    End If
   
End Sub
 Removes the points that are not curbing the polyline. This reduces the number of points on the polyline to those that are strictly required to keep its shape.
Private Sub ExportNamedPolyline(ByRef s_file As String)

    Dim bSel As Boolean
    Dim sPick As Variant
    Dim retObj As AcadObject
    Dim ThePoly As AcadLWPolyline
    Dim TheText As AcadText
    Dim TheMText As AcadMText
    Dim The_Name As String
    Dim fnum As Integer
    Dim a As Long
    Dim entries_cnt As Long

    ThisDrawing.ActiveSpace = acModelSpace
    
    fnum = FreeFile()
    Open s_file For Output As fnum
    entries_cnt = 0
    
    Do
    
        ' get the polyline to export
Resume_Poly:
        bSel = False
        On Error GoTo Err_Hdl_sel
        While (bSel = False)
        
            ThisDrawing.Utility.GetEntity _
                retObj, sPick, "Select polyline"
                
            If (TypeOf retObj Is AcadLWPolyline = False) Then
                ThisDrawing.Utility.Prompt ( _
                    "The object is not a polyline (" & _
                    retObj.ObjectName & ")!")
            Else
                bSel = True
            End If
        Wend
        Set ThePoly = retObj
        
        ' get the text to export
Resume_Text:
        bSel = False
        On Error GoTo Err_Hdl_sel_txt
        While (bSel = False)
        
            ThisDrawing.Utility.GetEntity _
                retObj, sPick, "Select text"
                
            If (TypeOf retObj Is AcadText = False) Then
                If (TypeOf retObj Is AcadMText = False) Then
                    ThisDrawing.Utility.Prompt ( _
                        "The object is not a text (" & _
                        retObj.ObjectName & ")!")
                Else
                    bSel = True
                    Set TheMText = retObj
                    The_Name = TheMText.textString
                End If
            Else
                bSel = True
                Set TheText = retObj
                The_Name = TheText.textString
            End If
        Wend
        
        Print #fnum, ">>>> " & CStr(entries_cnt) & _
            vbTab & The_Name & " <<<<"
        entries_cnt = entries_cnt + 1
        
        Dim polyCoords As Variant
        Dim polyCoordBound As Integer
        polyCoords = ThePoly.Coordinates
        polyCoordBound = UBound(polyCoords)
    
        For a = 0 To polyCoordBound - 1 Step 2
            Print #fnum, Format(polyCoords(a), "0.000") & _
                vbTab & Format(polyCoords(a + 1), "0.000")
        Next a
        
    Loop
    
Function_End:
    Close #fnum

    Exit Sub

'  ----------------------------------------------------------
Err_Hdl_sel:

    Call ThisDrawing.Utility.InitializeUserInput(0, "Y N")
    If (ThisDrawing.Utility.GetKeyword( _
        "Quit? Y/<N>") = "Y") Then
        Resume Function_End
    Else
        Resume Resume_Text
    End If
Err_Hdl_sel_txt:
    Call ThisDrawing.Utility.InitializeUserInput(0, "Y N")
    If (ThisDrawing.Utility.GetKeyword( _
        "Quit? Y/<N>") = "Y") Then
        Resume Function_End
    Else
        Resume Resume_Poly
    End If
    
End Sub
 Exports the named polyline to a text file. Th user picks alternatively the polyline and the text object and after each pair the code writes the text and the list of coordinates to file. The fields are tab-separated.
Private Sub GetPolyCenter( _
    ByRef ThePoly As AcadLWPolyline, _
    ByRef x As Double, _
    ByRef y As Double)

    Dim a As Long
    Dim xmax As Double, ymax As Double
    Dim xmin As Double, ymin As Double
    Dim polyCoords As Variant
    Dim polyCoordBound As Integer
    
    polyCoords = ThePoly.Coordinates
    polyCoordBound = UBound(polyCoords)
    
    xmax = polyCoords(0)
    ymax = polyCoords(1)
    xmin = polyCoords(0)
    ymin = polyCoords(1)
    For a = 2 To polyCoordBound - 1 Step 2
        If (xmax < polyCoords(a)) Then
            xmax = polyCoords(a)
        End If
        If (ymax < polyCoords(a + 1)) Then
            ymax = polyCoords(a + 1)
        End If
        If (xmin > polyCoords(a)) Then
            xmin = polyCoords(a)
        End If
        If (ymin > polyCoords(a + 1)) Then
            ymin = polyCoords(a + 1)
        End If
    Next a
    
    x = xmin + (xmax - xmin) / 2
    y = ymin + (ymax - ymin) / 2

End Sub
 A (rather silly) way of finding the center of the bounding box for a polyline.
Private Sub GetMassCenter( _
    ByRef ThePoly As AcadLWPolyline, _
    ByRef x As Double, _
    ByRef y As Double)
    
    Dim a As Long
    Dim i As Long
    Dim polyCoords As Variant
    Dim polyCoordBound As Integer
    Dim x_sum As Double
    Dim y_sum As Double
    
    x_sum = 0
    y_sum = 0
    i = 0
    polyCoords = ThePoly.Coordinates
    polyCoordBound = UBound(polyCoords)

    For a = 0 To polyCoordBound - 1 Step 2
        x_sum = x_sum + polyCoords(a)
        y_sum = y_sum + polyCoords(a + 1)
        i = i + 1
    Next a
    
    x = x_sum / i
    y = y_sum / i

End Sub
 Center of mass for a polyline.
Private Function isPointInPolyline( _
    pl As AcadLWPolyline, _
    ByVal p1 As Variant) As Boolean
    
    Dim p2 As Variant
    Dim ray As AcadRay
    Dim arr As Variant
    Dim upperbound As Long
    Dim IntersectionCount As Long
    Dim a As Long
    Dim xmax As Double, ymax As Double
    Dim xmin As Double, ymin As Double
    Dim polyCoords As Variant
    Dim polyCoordBound As Integer
    
    polyCoords = pl.Coordinates
    polyCoordBound = UBound(polyCoords)
    
    xmax = polyCoords(0)
    ymax = polyCoords(1)
    xmin = polyCoords(0)
    ymin = polyCoords(1)
    For a = 2 To polyCoordBound - 1 Step 2
        If (xmax < polyCoords(a)) Then
            xmax = polyCoords(a)
        End If
        If (ymax < polyCoords(a + 1)) Then
            ymax = polyCoords(a + 1)
        End If
        If (xmin > polyCoords(a)) Then
            xmin = polyCoords(a)
        End If
        If (ymin > polyCoords(a + 1)) Then
            ymin = polyCoords(a + 1)
        End If
    Next a

    If (p1(0) < xmin) Or (p1(0) > xmax) Then
        isPointInPolyline = False
        Exit Function
    End If
    If (p1(1) < ymin) Or (p1(1) > ymax) Then
        isPointInPolyline = False
        Exit Function
    End If
    
    p2 = p1
    ' edit on 03/12/2010 for increased reliability
    ' horizontal ray exchanged for a ray with a random direction
    'offset x coordinate for secondary point in Ray by random amount
    p2(0) = p2(0) + 1 - Rnd * 2
    'offset y coordinate for secondary point in Ray by random amount
    p2(1) = p2(1) + 1 - Rnd * 2
    ' end of edit

    Set ray = thisSpace.AddRay(p1, p2)
    arr = ray.IntersectWith(pl, acExtendNone)
    upperbound = UBound(arr)

    If upperbound = -1 Then
    ' No intersections - the point must not be inside the polyline
    ' Assumes no elevation
        isPointInPolyline = False
    Else
        IntersectionCount = (upperbound + 1) / 3
        'number of elements in array is equal to
        'the upperbound + 1 because of element zero
        'we divide by 3 to find the number of
        'individual intersections because each has
        '3 coordinates - X, Y and Z

        If IntersectionCount Mod 2 = 0 Then
        'There are an even number of intersections - it
        'cannot be inside the polyline
            isPointInPolyline = False
        Else
        'There are an odd number of intersections - it
        'must be inside the polyline
            isPointInPolyline = True
        End If

    End If
    ray.Delete
    
End Function
Finds if a point is inside a polyline or outside it
Private Sub selEntByPline()

    On Error Resume Next

    Dim objCadEnt As AcadEntity
    Dim vrRetPnt As Variant
    Dim objLWPline As AcadLWPolyline
    Dim objSSet As AcadSelectionSet
    Dim dblCurCords() As Double
    Dim dblNewCords() As Double
    Dim iMaxCurArr, iMaxNewArr As Integer
    Dim iCurArrIdx, iNewArrIdx, iCnt As Integer


    ThisDrawing.Utility.GetEntity objCadEnt, vrRetPnt
    If objCadEnt.ObjectName = "AcDbPolyline" Then
        Set objLWPline = objCadEnt
        
        '|-- The returned coordinates are 2D only --|
        dblCurCords = objLWPline.Coordinates
        iMaxCurArr = UBound(dblCurCords)
        
        If iMaxCurArr = 3 Then
            ThisDrawing.Utility.Prompt _
                "The selected polyline should " & _
                "have minimum 2 segments..."
            Exit Sub
        Else
            ' The 2D Coordinates are insufficient
            ' to use in SelectByPolygon method
            ' So convert those into 3D coordinates
            iMaxNewArr = ((iMaxCurArr + 1) * 1.5) - 1
            ReDim dblNewCords(iMaxNewArr) As Double
            
            iCurArrIdx = 0: iCnt = 1
            For iNewArrIdx = 0 To iMaxNewArr
                If iCnt = 3 Then
                '|-- The z coordinate is set to 0 --|
                    dblNewCords(iNewArrIdx) = 0
                    iCnt = 1
                Else
                    dblNewCords(iNewArrIdx) = _
                        dblCurCords(iCurArrIdx)
                    iCurArrIdx = iCurArrIdx + 1
                    iCnt = iCnt + 1
                End If
            Next
            Set objSSet = ThisDrawing.SelectionSets.Add("SEL_ENT")
            objSSet.SelectByPolygon _
                acSelectionSetWindowPolygon, dblNewCords
            objSSet.Highlight True
            objSSet.Delete
        End If
    Else
        ThisDrawing.Utility.Prompt _
            "The selected object is not a 2D Polyline...."
    End If
    If Err.Number <> 0 Then
        MsgBox Err.Description
        Err.Clear
    End If
End Sub
 The routine uses selected polyline ( pre-selected or selected by user as we run) to select the objects inside it.
Private Function HasLayer(ByRef s_lay_name As String) As Boolean

    On Error GoTo not_found
    Dim lay As AcadLayer
    
    Set lay = ThisDrawing.Layers(s_lay_name)
    HasLayer = True
    Exit Function
    
not_found:
    HasLayer = False

End Function 
 Checks if a layer is present in the current draw
Private Function HasBlock(ByRef s_block_name As String) As Boolean

    On Error GoTo not_found
    
    Dim blks As AcadBlock
    Set blks = ThisDrawing.Blocks(s_block_name)
    HasBlock = True
    Exit Function
    
not_found:
    HasBlock = False

End Function 
 Checks if a block is present in the current drawing
Private Sub EnshureLayer(ByRef s_lay_name As String)
    
    If (HasLayer(s_lay_name) = False) Then
        Call ThisDrawing.Layers.Add(s_lay_name)
    End If
    
End Sub 
 Creates a layer if it does not exist in current drawing.
Private Sub AttributeInBlocks( _
    ByRef TheBlock As AcadBlockReference)

    Dim AttList As Variant
    Dim i As Integer
    
    AttList = TheBlock.GetAttributes
    For i = LBound(AttList) To UBound(AttList)
        Select Case AttList(i).TagString
        Case "TAG_A"
            Debug.Print AttList(i).textString
        Case "TAG_B"
            Debug.Print AttList(i).textString
            AttList(i).textString = "some text"
        Case "TAG_C"
            Debug.Print AttList(i).textString
        End Select
    Next
    
End Sub
 Accessing and modifying attributes in a block instance.
Private Sub AddBlockWithAttrib(ByRef s_name As String)

    Dim TheBlock As AcadBlock
    Dim TheAttrib As AcadAttribute
    Dim pt(0 To 2) As Double
    Dim pt_a(0 To 2) As Double
    Dim txHeight As Double
    
    ' check if this block is defined
    If (HasBlock(s_name) = False) Then
    
        ' height of the attribute text
        txHeight = 0.2
        
        ' position of the block
        pt(0) = 0
        pt(1) = 0
        pt(2) = 0
        
        ' position of the attribute
        pt_a(0) = 0
        pt_a(1) = 0
        pt_a(2) = 0
        
        Set TheBlock = ThisDrawing.Blocks.Add(pt, s_name)
        Set TheAttrib = TheBlock.AddAttribute( _
            txHeight, _
            acAttributeModeNormal, _
            "Input value:", _
            pt_a, _
            "TAG_A", _
            "Default val for A")
        
        TheAttrib.Layer = "0"
    
    End If
End Sub
 Create a block definition with an attribute inside.