Make VBA modify the UCS

2010-02-20T21:16:00.000-08:00

I've spent a lot of time scouring the internet on how to program VBA in AutoCad and Excel and both. What I've found is that despite all the resources out there I had to figure a lot of things out on my own. Well, for the remaining year while AutoCad still offers VBA support I thought I would wholesale post everything. Today's lesson: Understand the Acad UCS and make VBA change it for you.

Ok, so first off, there are a lot of different code bits you can dig up if you type in VBA and UCS into google, most of the ones I found to be inadequate or just wrong. What I wanted was a function that could take a line and rotate the UCS based on that startpoint of that line. There is no such code you will find on the inter-webs. Except here.

Things to remember:

The UCS is manipulated by the X, Y and origin coordinates only. If you want to rotate the on the Z axis change the location of the z coordinate in the X/Y vector
The X and Y vectors must be perpendicular to one another. If your X and Y are not perpendicular then you get an ugly error message and you are attempting to use a non rectangular coordinate system which doesn't really exist.
Understand How the Trigonometric Functions in different quadrants affect what you are doing.
The UCS is comprised of an X,Y and Z vector that is defined by the X, Y and Origin point.

For this code to work you need an origin point and a X(x,y,z) and a Y(x,y,z)

For my purposes I wrote some code that selects lines in a drawing and uses the origin point of the line to rotate the the UCS.

First you need to Dimension some variables:

Dim Origin(2) As Double 'origin array

Dim xAxisPNT(2) As Double 'xaxis point

Dim yAxisPNT(2) As Double 'yaxis point

Dim Rotation as double 'the rotation angle of the line

Dim bSIN As Double

Dim bCOS As Double

Dim bTAN As Double

Dim ucsObj As AcadUCS

bSIN = Sin(rotation)

bCOS = Cos(rotation)

bTAN = Tan(rotation)

All you need here is the ORIGIN Point and the rotation of the line, (I'll cover selecting the line in a later post) here's the math:

NOTE: ABS value was used for all the formulas, even though it was _

not needed for all the formulas. _

select case TRUE

'case quadrant I, all functions are positive

Case bSIN > 0 And bCOS > 0 And bTAN > 0

xAxisPNT(0) = Origin(0) + 1 * Cos(rotation) 'x1

xAxisPNT(1) = Origin(1) + 1 * Sin(rotation) 'y1

yAxisPNT(0) = Origin(0) - 1 * Sin(rotation) 'x2

yAxisPNT(1) = Origin(1) + 1 * Cos(rotation) 'y2

'case quadrant II, sine is positive

Case bSIN > 0 And bCOS <>

'quadrant II rotation x,y

xAxisPNT(0) = Origin(0) - 1 * Abs(Cos(rotation)) 'x

xAxisPNT(1) = Origin(1) + 1 * Abs(Sin(rotation)) 'y

yAxisPNT(0) = Origin(0) - 1 * Abs(Sin(rotation)) 'x2

yAxisPNT(1) = Origin(1) - 1 * Abs(Cos(rotation)) 'y2

'case quadrant III, tan is positive

Case bSIN <> 0

'quadrant III rotation x,y

xAxisPNT(0) = Origin(0) - 1 * Abs(Cos(rotation)) 'x2

xAxisPNT(1) = Origin(1) - 1 * Abs(Sin(rotation)) 'y2

yAxisPNT(0) = Origin(0) - 1 * Abs(Sin(rotation)) 'x

yAxisPNT(1) = Origin(1) + 1 * Abs(Cos(rotation)) 'y

'case quadrant IV, cosine is posistive

'quadrant III rotation x,z

Case bSIN <> 0 And bTAN <>

'quadrant IV rotation x,y

xAxisPNT(0) = Origin(0) + 1 * Abs(Cos(rotation)) 'x

xAxisPNT(1) = Origin(1) - 1 * Abs(Sin(rotation)) 'y

yAxisPNT(0) = Origin(0) + 1 * Abs(Sin(rotation)) 'x2

yAxisPNT(1) = Origin(1) + 1 * Abs(Cos(rotation)) 'y2

'case rotation = 180

Case bCOS = -1

'x,y

xAxisPNT(0) = Origin(0) - 1

xAxisPNT(1) = Origin(1)

yAxisPNT(0) = Origin(0)

yAxisPNT(1) = Origin(1) - 1

'case rotation = 90

Case bSIN = 1

'x,y

xAxisPNT(0) = Origin(0)

xAxisPNT(1) = Origin(1) + 1

yAxisPNT(0) = Origin(0) - 1

yAxisPNT(1) = Origin(1)

'case rotation = 270

Case bSIN = -1

xAxisPNT(0) = Origin(0)

xAxisPNT(1) = Origin(1) - 1

yAxisPNT(0) = Origin(0) + 1

yAxisPNT(1) = Origin(1)

End select

Set ucsObj = ThisDrawing.UserCoordinateSystems.Add _

(Origin, xAxisPNT, yAxisPNT, "New_UCS")

ThisDrawing.ActiveUCS = ucsObj

And that's it for X, Y... however, I wanted to rotate to the X, Z so my cases were slightly different:

Select Case True

'case rotation = 0

Case bCOS = 1

'X,Z

xAxisPNT(0) = Origin(0) + 1

xAxisPNT(1) = Origin(1)

yAxisPNT(0) = Origin(0)

yAxisPNT(1) = Origin(1)

yAxisPNT(2) = Origin(1) + 1

'case rotation = 180

Case bCOS = -1

'x,z

xAxisPNT(0) = Origin(0) - 1

xAxisPNT(1) = Origin(1)

yAxisPNT(0) = Origin(0)

yAxisPNT(1) = Origin(1)

yAxisPNT(2) = Origin(1) + 1

'case rotation = 90

Case bSIN = 1

'x,z

xAxisPNT(0) = Origin(0)

xAxisPNT(1) = Origin(1) + 1

yAxisPNT(0) = Origin(0)

yAxisPNT(1) = Origin(1)

yAxisPNT(2) = Origin(1) + 1

'case rotation = 270

Case bSIN = -1

xAxisPNT(0) = Origin(0)

xAxisPNT(1) = Origin(1) - 1

yAxisPNT(0) = Origin(0)

yAxisPNT(1) = Origin(1)

yAxisPNT(2) = Origin(1) + 1

'case quadrant I, all functions are positive

Case bSIN > 0 And bCOS > 0 And bTAN > 0

'Quadrant I rotation, x,z

xAxisPNT(0) = Origin(0) + 1 * Cos(rotation) 'x1

xAxisPNT(1) = Origin(1) + 1 * Sin(rotation) 'y1

yAxisPNT(0) = Origin(0)

yAxisPNT(1) = Origin(1)

yAxisPNT(2) = Origin(1) + 1 * Cos(rotation) 'y2

'case quadrant II, sine is positive

Case bSIN > 0 And bCOS <>

'quadrant II rotation x,z

xAxisPNT(0) = Origin(0) - 1 * Abs(Cos(rotation)) 'x

xAxisPNT(1) = Origin(1) + 1 * Abs(Sin(rotation)) 'y

yAxisPNT(0) = Origin(0)

yAxisPNT(1) = Origin(1)

yAxisPNT(2) = Origin(1) - 1 * Abs(Cos(rotation)) 'y2

'case quadrant III, tan is positive

Case bSIN <> 0

'quadrant III rotation x,z

xAxisPNT(0) = Origin(0) - 1 * Abs(Cos(rotation)) 'x2

xAxisPNT(1) = Origin(1) - 1 * Abs(Sin(rotation)) 'y2

yAxisPNT(0) = Origin(0)

yAxisPNT(1) = Origin(1)

yAxisPNT(2) = Origin(1) + 1 * Abs(Cos(rotation)) 'y

'case quadrant IV, cosine is posistive

Case bSIN <> 0 And bTAN <>

'quadrant IV rotation x,z

xAxisPNT(0) = Origin(0) + 1 * Abs(Cos(rotation)) 'x

xAxisPNT(1) = Origin(1) - 1 * Abs(Sin(rotation)) 'y

yAxisPNT(0) = Origin(0)

yAxisPNT(1) = Origin(1)

yAxisPNT(2) = Origin(1) + 1 * Abs(Cos(rotation)) 'y2

End Select

Hopefully that demystifies the UCS a little. Feel Free to use this code, modify it, bend it to your will, just let me know! And feel free to email me with any questions or comments!

Pennington.Pennington@Gmail.com

AutoCad VBA

Make VBA modify the UCS