VBA CAD

Library bindings

For library binding to ActiveX objects from AutoCAD (or equivalent software), we can follow these posts on StackOverflow and theSwamp.org, that gives us the references for AutoCAD application. For every software, and for each every version, there will be a different GUI code, so take care.

‘[HKEY_CLASSES_ROOT\AutoCAD.Application\CurVer]
‘@=”AutoCAD.Application.21″

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application.21]

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application.21\CLSID]
‘@=”{0D327DA6-B4DF-4842-B833-2CFF84F0948F}”

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application]
‘@=”AutoCAD Application”

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application\CLSID]
‘@=”{0D327DA6-B4DF-4842-B833-2CFF84F0948F}”

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application\CurVer]
‘@=”AutoCAD.Application.21″

Another ‘better’ option is to go with ‘Late binding’ (instead of ‘Early binding’ that needs the references to be set in the VBA project). It’s no so clear and get developers far away from IntellySense, but knowing the objects, methods and properties, you can manage. It has the tremendous advantage that there is no need for the software version user has installed on his/her computer to be the same as in the developer’s (of course, they must have the same CAD software…).

These are late binding declarations for the two common objects (oCADApp and oCADDoc).

Private oCadApp As Object 'AutoCAD.AutoCADApplication or BricscadApp.AcadApplication
Private oCadDoc As Object 'AutoCAD.AutoCADDrawing or BricscadApp.AcadDocument

Opening a drawing in CAD. Linking to objects

To draw inside CAD application through VBA we need to link the CAD application instante and the CAD drawing document, in order to do it programmatically use following code:

Private oCadApp As Object 'AutoCAD.AutoCADApplication or BricscadApp.AcadApplication
Private oCadDoc As Object 'AutoCAD.AutoCADDrawing or BricscadApp.AcadDocument

Private Function fCADOpen(ByRef oCadApp As Object, _
                          ByRef oCadDoc As Object, _
                          Optional ByRef strFullPath_File As String = vbNullString) As Boolean
' Get CAD instance and CAD drawing document

    'Check if AutoCAD application is open. If not, create a new instance and make it visible.
    On Error Resume Next
    Set oCadApp = GetObject(, "AutoCAD.Application") '(, "BricscadApp.Application") '= New BricscadApp.AcadApplication in Early binding
    If oCadApp Is Nothing Then
    ' or also:
    'If Err.Description > vbNullString Then
    '    Err.Clear
        Set oCadApp = CreateObject("AutoCAD.Application") '("BricscadApp.Application")
        oCadApp.Visible = True
    End If

    'Check if there is an AutoCAD object.
    If oCadApp Is Nothing Then
        MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
        fCADOpen = False: GoTo ExitProc
    End If
    On Error GoTo 0

    'Check if there is an active drawing. If no active drawing is found, create a new one.
    On Error Resume Next
    'strFullPath_File = VBA.Environ("UserProfile") & "\Documents\Doc.dxf"
    'Set oCadDoc = oCadApp.Documents.Open (strFullPath_File)
    Set oCadDoc = oCadApp.ActiveDocument
    If oCadDoc Is Nothing Then
        Set oCadDoc = oCadApp.Documents.Add
    End If
    On Error GoTo 0

    If oCadDoc Is Nothing Then fCADOpen = False: GoTo ExitProc

    'Check if the active space is paper space and change it to model space.
    With oCadDoc
        If .ActiveSpace = 0 Then '0 = acPaperSpace in early binding
           .ActiveSpace = 1      '1 = acModelSpace in early binding
        End If
    End With

ExitProc:
    On Error GoTo 0
    Exit Function
End Function

Remember that the CAD object is open, to close it programmatically, use following code:

Public Function fCloseCAD(Optional ByVal strFullPathFile_CAD As String = vbNullString)
    If strFullPathFile_CAD = vbNullString Then
        strFullPathFile_CAD = VBA.Environ("UserProfile") & "\Documents\Unknown.dwg"
    End If

    oCadDoc.SaveAs strFullPathFile_CAD
    oCadApp.Documents.Close

    oCadApp.Quit

    Set oCadDoc = Nothing
    Set oCadApp = Nothing
End Function

Drawing in CAD data from Excel

If we want to draw some entities, we can use something like these codes, derived from theSwamp.org, and Christos Samaras’s (My Engineering World) posts 1 (to draw a 2D polyline) and 2 (to draw a 3D polyline with a extruded section). Modify to your convenience.

Public Sub DrawText()
Dim strFullPath_File As String

Dim Height As Double
Dim P(0 To 2) As Double
Dim oCADText As Object 'AutoCAD.AutoCADApplication.AcadText or BricscadApp.AcadText
Dim TxtStr As String

Height = 1
P(0) = 1: P(1) = 1: P(2) = 0
TxtStr = Cells(1, 1)

Set oCADText = oCadDoc.ModelSpace.AddText(TxtStr, P, Height)

Set oCADText = Nothing
End Sub

Public Sub sDrawPolyline()
'Draws a polyline in AutoCAD using X and Y coordinates from sheet Coordinates.

'Declaring the necessary variables.
Dim oCadPol As Object 'AcadLWPolyline
Dim dblCoordinates() As Double
Dim LastRow As Long
Dim i As Long
Dim j As Long
Dim k As Long

Dim wsData As Excel.Worksheet
Dim rgData As Excel.Range

' Get data
'Set rgData = Application.InputBox(Prompt:="Select range of points", _
Title:="Select data", _
Default:=Selection.Address(True, True), _
Type:=8)

Set wsData = rgData.Parent 'ActiveSheet
With wsData
.Activate

'Find the last row.
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

'Check if there are at least two points.
If LastRow < 3 Then
MsgBox "There not enough points to draw the polyline!", vbCritical, "Points Error"
Exit Sub
End If

'Get the array size.
ReDim dblCoordinates(2 * (LastRow - 1) - 1)

'Pass the coordinates to array.
k = 0
For i = 2 To LastRow
For j = 1 To 2
dblCoordinates(k) = .Cells(i, j)
k = k + 1
Next j
Next i
End With

' Get CAD app and Doc
Call fCADOpen(oCadApp, oCadDoc)

'Draw the polyline either at model space or at paper space.
'If oCadDoc.ActiveSpace = acModelSpace Then
Set oCadPol = oCadDoc.ModelSpace.AddLightWeightPolyline(dblCoordinates)
'Else
' Set oCadPol = oCadDoc.PaperSpace.AddLightWeightPolyline(dblCoordinates)
'End If

'Leave the polyline open (the last point is not connected with the first point).
'Set the next line to true if you need to connect the last point with the first one.
oCadPol.Closed = False
oCadPol.Update

'Zooming in to the drawing area.
oCadApp.ZoomExtents

'Inform the user that the polyline was created.
MsgBox "The polyline was successfully created!", vbInformation, "Finished"

End Sub

Public Sub sDraw3DPolyline()
' Draws a 3D polyline in AutoCAD using X, Y and Z coordinates from the sheet Coordinates.
' If the user enter a radius value the code transforms the 3D polyline to a pipe-like solid, using
' the AddExtrudedSolidAlongPath method. In this way you can draw a pipeline directly from Excel!

' Remarks: You can extrude only 2D planar regions.
' The path should not lie on the same plane as the profile, nor should it have areas of high curvature.

' Although the available path objects not include the 3D polyline, we can use this object,
' but taking into account the fact that both Profile and Path objects must not lie on the same plane. We can overcome this limitation with a simple trick:
' we rotate the Profile object!
' So, in the particular case, we rotate the circle 45 degrees over the y axis,
' in order the circle plane to be different than the 3D polyline plane(s).
' Moreover, we apply the Move method in order to move the 3D "solid" polyline back to its original position
'(since the AddExtrudedSolidAlongPath method will start drawing the 3D “solid” polyline at profile's coordinates - usually at (0,0,0)).

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Can also be achieved with the SWEEP command/method over an SCR phrase
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

' Declaring the necessary variables.
Dim oCad3DPol As Object 'BricscadApp.Pol3D
Dim oCircle(0 To 0) As Object 'BricscadApp.Circle
Dim oSolidPol As Object 'BricscadApp.Solid3D

Dim LastRow As Long
Dim dblCoordinates() As Double
Dim i As Long
Dim j As Long
Dim k As Long
Dim CircleCenter(0 To 2) As Double
Dim CircleRadius As Double
Dim RotPoint1(2) As Double
Dim RotPoint2(2) As Double
Dim Regions As Variant
Dim FinalPosition(0 To 2) As Double

Dim lgRetVal As Long

Dim wsData As Excel.Worksheet
Dim rgRadius As Excel.Range
Dim rgCoordinates As Excel.Range

' Get coordinates data
'Set rgCoordinates = Application.InputBox(Prompt:="Select range of points", _
Title:="Select data", _
Default:=Selection.Address(True, True), _
Type:=8)

Set wsData = rgCoordinates.Parent 'ActiveSheet
With wsData
.Activate

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

'Check if there are at least two points.
If LastRow 0 Then
' Set the circle center at the (0,0,0) point.
CircleCenter(0) = 0: CircleCenter(1) = 0: CircleCenter(2) = 0

' Draw the circle.
Set oCircle(0) = oCadDoc.ModelSpace.AddCircle(CircleCenter, CircleRadius)

' Initialize the rotational axis.
RotPoint1(0) = 0: RotPoint1(1) = 0: RotPoint1(2) = 0
RotPoint2(0) = 0: RotPoint2(1) = 10: RotPoint2(2) = 0

' Rotate the circle in order to avoid errors with AddExtrudedSolidAlongPath method.
oCircle(0).Rotate3D RotPoint1, RotPoint2, 0.785398163 '45 degrees

' Create a region from the circle.
Regions = oCadDoc.ModelSpace.AddRegion(oCircle)

' Create the "solid polyline".
Set oSolidPol = oCadDoc.ModelSpace.AddExtrudedSolidAlongPath(Regions(0), oCad3DPol)

' Set the position where the solid should be transfered after its design (its original position).
With Sheets("Coordinates")
FinalPosition(0) = .Range("A2").Value
FinalPosition(1) = .Range("B2").Value
FinalPosition(2) = .Range("C2").Value
End With

' Move the solid to its final position.
oSolidPol.Move CircleCenter, FinalPosition

' Delete the circle.
oCircle(0).Delete

' Delete the region.
Regions(0).Delete

' If the "solid polyline" was created successfully delete the initial polyline.
If Err.Number = 0 Then
oCad3DPol.Delete
End If
End If

' Zooming in to the drawing area.
oCadApp.ZoomExtents

' Release the objects.
Set oCircle(0) = Nothing
Set oSolidPol = Nothing
Set oCad3DPol = Nothing

' Inform the user that the 3D polyline was created.
lgRetVal = MsgBox("The 3D polyline was successfully created in AutoCAD!", vbInformation, "Finished")

End Sub
[/sourcecode]

Leave a Reply

Your email address will not be published. Required fields are marked *