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.