This example shows how to use TranslateCoordinates and TransformBy methods, which are very helpful when drawing 3D objects in autoCAD with VBA
It first draws a closed polyline on the orginal UCS. The original UCS is given a name ‘OriginalUCSj’ so that we can activate the original UCS again.
The polyline is then moved to a new UCS call ‘UCSName1’
It can then be extruded in that new plane we created in the -Z direction of the original USC
Another USC called ‘UCSName2’ is created in which we draw a circle at the origin of that new UCS.
NOTE: all images above are shown form the top view of the original UCS or world UCS
Option Explicit
Dim acadDoc As Object
Dim AcadUcsObject As AcadUCS
Function Cross3D(A As Variant, B As Variant) As Variant
Dim variable_C(0 To 2) As Double
variable_C(0) = A(1) * B(2) - A(2) * B(1)
variable_C(1) = -(A(0) * B(2) - A(2) * B(0))
variable_C(2) = A(0) * B(1) - A(1) * B(0)
Cross3D = variable_C
End Function
Function Add_UCS_improved(origin As Variant, xAxisPnt _
As Variant, yAxisPnt As Variant, ucsName As String) As AcadUCS
Dim xAxisVec(0 To 2) As Double
Dim yAxisVec(0 To 2) As Double
Dim perpYaxisPnt(0 To 2) As Double
Dim xCy As Variant, perpYaxisVec As Variant
xAxisVec(0) = xAxisPnt(0) - origin(0)
xAxisVec(1) = xAxisPnt(1) - origin(1)
xAxisVec(2) = xAxisPnt(2) - origin(2)
yAxisVec(0) = yAxisPnt(0) - origin(0)
yAxisVec(1) = yAxisPnt(1) - origin(1)
yAxisVec(2) = yAxisPnt(2) - origin(2)
xCy = Cross3D(xAxisVec, yAxisVec)
perpYaxisVec = Cross3D(xCy, xAxisVec)
perpYaxisPnt(0) = perpYaxisVec(0) + origin(0)
perpYaxisPnt(1) = perpYaxisVec(1) + origin(1)
perpYaxisPnt(2) = perpYaxisVec(2) + origin(2)
Set AcadUcsObject = acadDoc.UserCoordinateSystems.Add(origin, xAxisPnt, _
perpYaxisPnt, ucsName)
End Function
Sub draw_CNC_flashing_3Dverify()
Dim circleObj(1) As AcadCircle
Dim pointUCS As Variant
Dim solidObjextrus_sides1 As Acad3DSolid
Dim curves_sides(0) As AcadEntity
Dim vertices() As Double
Dim acadApp As Object
Dim currUCS As AcadUCS
Dim PointVariantOrigin(0 To 2) As Double
Dim PointVariantXAxis(0 To 2) As Double
Dim PointVariantYAxis(0 To 2) As Double
Dim plineObjLW As AcadLWPolyline
Dim TransMatrix As Variant
Dim regionObj As Variant
Dim center(0 To 2) As Double
Dim pointObj1 As AcadPoint
'Check if AutoCAD application is open. If it is not opened create a new instance and make it visible.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
acadApp.Visible = True
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application")
acadApp.Visible = True
End If
'Check (again) if there is an AutoCAD object.
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
Exit Sub
End If
On Error GoTo 0
acadApp.WindowState = acMax
'If there is no active drawing create a new one.
On Error Resume Next
Set acadDoc = acadApp.Documents.Add
If Err.Number <> 0 Then
MsgBox "Could not get the AutoCAD application. Restart Autocad and try again"
End
End If
On Error GoTo 0
acadDoc.ActiveSpace = acModelSpace
'define the original ucs
With acadDoc
Set currUCS = .UserCoordinateSystems.Add( _
.GetVariable("UCSORG"), _
.Utility.TranslateCoordinates(.GetVariable("UCSXDIR"), acUCS, acWorld, 0), _
.Utility.TranslateCoordinates(.GetVariable("UCSYDIR"), acUCS, acWorld, 0), _
"OriginalUCSj")
End With
ReDim vertices(7)
vertices(0) = 0: vertices(1) = 0 'vertex 1
vertices(2) = 25: vertices(3) = 50 'vertex 2
vertices(4) = 75: vertices(5) = 50 'vertex 3
vertices(6) = 75: vertices(7) = 0 'vertex 4
Set plineObjLW = acadDoc.ModelSpace.AddLightWeightPolyline(vertices)
plineObjLW.Closed = True
PointVariantOrigin(0) = 0
PointVariantOrigin(1) = 0
PointVariantOrigin(2) = 0
PointVariantXAxis(0) = 50
PointVariantXAxis(1) = 0
PointVariantXAxis(2) = 0
PointVariantYAxis(0) = 0
PointVariantYAxis(1) = 0
PointVariantYAxis(2) = 50
Call Add_UCS_improved(PointVariantOrigin, PointVariantYAxis, PointVariantXAxis, "UCSName1")
TransMatrix = AcadUcsObject.GetUCSMatrix()
plineObjLW.TransformBy (TransMatrix)
Set curves_sides(0) = plineObjLW
regionObj = acadDoc.ModelSpace.AddRegion(curves_sides)
Set solidObjextrus_sides1 = acadDoc.ModelSpace.AddExtrudedSolid(regionObj(0), -50, 0)
regionObj(0).Delete
PointVariantOrigin(0) = 0
PointVariantOrigin(1) = 0
PointVariantOrigin(2) = 0
PointVariantXAxis(0) = 10
PointVariantXAxis(1) = -8
PointVariantXAxis(2) = 0
PointVariantYAxis(0) = 0
PointVariantYAxis(1) = 0
PointVariantYAxis(2) = 2
Call Add_UCS_improved(PointVariantOrigin, PointVariantYAxis, PointVariantXAxis, "UCSName2")
acadDoc.ActiveUCS = AcadUcsObject
Dim cir_rad As Double
cir_rad = 25
center(0) = 0
center(1) = 0
center(2) = 0
pointUCS = acadDoc.Utility.TranslateCoordinates(center, acUCS, acWorld, False)
Set circleObj(1) = acadDoc.ModelSpace.AddCircle(pointUCS, cir_rad)
Set pointObj1 = acadDoc.ModelSpace.AddPoint(pointUCS)
'return to the original UCS
acadDoc.ActiveUCS = currUCS
acadDoc.Regen acAllViewports
acadApp.ZoomExtents
End Sub
Coding with Visual Basic 