It seems that a block inserted on the ocs will always have a rotation of zero.

If you align the block to the line you will find the block has a rotation and that is the rotation that the ocs x axis has from the world axis

The following makes the use of the ocs consistant with the align command

`Option Explicit`

Const pi As Double = 3.14159265358979

Public Sub draw2()

Dim Line As AcadLine, basePnt As Variant

ThisDrawing.Utility.GetEntity Line, basePnt, "Select a line only:"

Dim mat

Dim Rot As Double

Dim vx(2) As Double, vy(2) As Double, vz(2) As Double

'get the lines ep-sp vector to create the z axis:

vz(0) = Line.EndPoint(0) - Line.StartPoint(0)

vz(1) = Line.EndPoint(1) - Line.StartPoint(1)

vz(2) = Line.EndPoint(2) - Line.StartPoint(2)

'normalise it:

VecNorm vz

mat = MatrixFromNormal(vz, Line.StartPoint, Rot)

Dim objRegEnt(0) As AcadEntity, objRegion As Variant

Dim objBlockRef As AcadBlockReference, objBlockExplode As Variant

Dim objBeam As Acad3DSolid

Dim ptInsert(2) As Double

Dim lCounter As Integer

Dim UCS As AcadUCS

Set UCS = GetActiveUcs

SetOrthoUCS

Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock(ptInsert, _

"310UB040", 1#, 1#, 1#, Rot)

objBlockExplode = objBlockRef.Explode

objBlockRef.Delete

For lCounter = LBound(objBlockExplode) To UBound(objBlockExplode)

If objBlockExplode(lCounter).ObjectName = "AcDbPolyline" Then

Set objRegEnt(0) = objBlockExplode(lCounter)

objRegion = ThisDrawing.ModelSpace.AddRegion(objRegEnt)

Exit For

End If

Next lCounter

Set objBeam = ThisDrawing.ModelSpace.AddExtrudedSolid(objRegion(0), Line.Length, 0)

objRegion(0).Delete

objRegEnt(0).Delete

objBeam.TransformBy (mat)

ThisDrawing.ActiveUCS = UCS

End Sub

Public Function VecNorm(ByRef vec() As Double)

'Normalises the incoming vector.

Dim unit As Double

unit = Sqr(vec(0) * vec(0) + vec(1) * vec(1) + vec(2) * vec(2))

vec(0) = vec(0) / unit: vec(1) = vec(1) / unit: vec(2) = vec(2) / unit

End Function

Function NormaliseVector(V As Variant) As Variant

Dim unit As Double

Dim Vn(2) As Double

unit = Sqr(V(0) * V(0) + V(1) * V(1) + V(2) * V(2))

Vn(0) = V(0) / unit: Vn(1) = V(1) / unit: Vn(2) = V(2) / unit

NormaliseVector = Vn

End Function

Function MatrixFromNormal(N As Variant, orig As Variant, Rot As Double) As Variant

Dim m(3, 3) As Double

Dim Z

Dim Wy(2) As Double, Wz(2) As Double

Dim Nx As Double, Ny As Double

Dim Ax, Ay As Variant

N = NormaliseVector(N)

Wy(0) = 0: Wy(1) = 1: Wy(2) = 0

Wz(0) = 0: Wz(1) = 0: Wz(2) = 1

Nx = N(0): Ny = N(1)

If (Abs(Nx) < 1 / 64) And (Abs(Ny) < 1 / 64) Then

'Ax = Wy X N (where X is the cross-product operator).

Ax = Crossproduct(Wy, N)

Else

Ax = Crossproduct(Wz, N)

End If

Ay = Crossproduct(N, Ax)

'Z = Crossproduct(Ax, Ay)

Z = N

m(0, 0) = Ax(0): m(0, 1) = Ay(0): m(0, 2) = Z(0): m(0, 3) = orig(0)

m(1, 0) = Ax(1): m(1, 1) = Ay(1): m(1, 2) = Z(1): m(1, 3) = orig(1)

m(2, 0) = Ax(2): m(2, 1) = Ay(2): m(2, 2) = Z(2): m(2, 3) = orig(2)

m(3, 0) = 0: m(3, 1) = 0: m(3, 2) = 0: m(3, 3) = 1

MatrixFromNormal = m

Dim Wx(2) As Double

Wx(0) = 1

Dim P

P = TransformPt2(m, Wx)

Rot = -AngFromX(orig, P)

End Function

Function TransformPt2(m As Variant, P1 As Variant) As Variant

Dim i As Integer

Dim X As Double, Y As Double, Z As Double, d As Double

Dim P(3) As Double

Dim P2(2) As Double

For i = 0 To 2

P(i) = P1(i)

Next

P(3) = 1

For i = 0 To 3

X = X + P(i) * m(0, i)

Y = Y + P(i) * m(1, i)

Z = Z + P(i) * m(2, i)

d = d + P(i) * m(3, i)

Next

P2(0) = X: P2(1) = Y: P2(2) = Z

TransformPt2 = P2

End Function

Function Crossproduct(a, B) As Variant

Dim Ax As Double, Ay As Double, Az As Double

Dim Bx As Double, By As Double, Bz As Double

Dim unit As Double

Dim C(2) As Double

'get CrossProduct

Ax = a(0): Ay = a(1): Az = a(2)

Bx = B(0): By = B(1): Bz = B(2)

C(0) = Ay * Bz - Az * By

C(1) = Az * Bx - Ax * Bz

C(2) = Ax * By - Ay * Bx

'Convert to unit normal

unit = Sqr(C(0) * C(0) + C(1) * C(1) + C(2) * C(2))

C(0) = C(0) / unit: C(1) = C(1) / unit: C(2) = C(2) / unit

Crossproduct = C

End Function

Public Function AngFromX(P1, P2) As Double

'If Not PointCheck(p1, p2) Then Exit Function

Dim Dx As Double, dY As Double

Dim dAng As Double

dY = P2(1) - P1(1): Dx = P2(0) - P1(0)

If Rd(dY, 0) Then 'Line is horizontal

If Rd(Dx, 0) Then Exit Function

If Dx > 0 Then

dAng = 0

Else

dAng = pi '180

End If

ElseIf Rd(Dx, 0) Then 'Line is vertical

If dY > 0 Then

dAng = 0.5 * pi '90

Else

dAng = 1.5 * pi '270

End If

Else

dAng = Atn(dY / Dx)

If dAng < 0 Then '90->270

If Dx < 0 Then '90->270

dAng = pi + dAng '90->180

Else '270->360

dAng = 2 * pi + dAng

End If

Else

If Dx < 0 And dY < 0 Then '180->270

dAng = pi + dAng

End If

End If

End If

AngFromX = dAng

End Function

Function Rd(num1 As Variant, num2 As Variant) As Boolean

Dim dRet As Double

dRet = num1 - num2

If Abs(dRet) < 0.00000001 Then Rd = True

End Function

Function GetActiveUcs() As AcadUCS

Dim Origin

Dim Xaxis

Dim Yaxis

Dim strNm As String, sUcs As String

Dim Zero(2) As Double

sUcs = ThisDrawing.GetVariable("UCSNAME")

If sUcs = "" Then

' Current UCS is not saved so get the data and save it

'A ucs is saved when a user makes and saves one or

' a user clicks on an isoview button

With ThisDrawing

If .GetVariable("WORLDUCS") = 1 Then

Xaxis = Zero: Yaxis = Zero

Xaxis(0) = 1: Yaxis(1) = 1

Set GetActiveUcs = ThisDrawing.UserCoordinateSystems.Add(Zero, Xaxis, Yaxis, "World")

Exit Function

End If

Origin = .GetVariable("UCSORG")

Xaxis = .GetVariable("UCSXDIR")

Yaxis = .GetVariable("UCSYDIR")

strNm = "Active"

End With

Set GetActiveUcs = ThisDrawing.UserCoordinateSystems.Add(Zero, Xaxis, Yaxis, strNm)

'Changing the origin later stops the error message

'-2145320930 UCS X axis and Y axis are not perpendicular

GetActiveUcs.Origin = Origin

ThisDrawing.ActiveUCS = GetActiveUcs

Else

Select Case sUcs

Case "*TOP*", "TOP"

Set GetActiveUcs = SetOrthoUCS("Top")

Case "*BOTTOM*"

Set GetActiveUcs = SetOrthoUCS("Bottom")

Case "*LEFT*"

Set GetActiveUcs = SetOrthoUCS("Left")

Case "*RIGHT*"

Set GetActiveUcs = SetOrthoUCS("Right")

Case "*FRONT*"

Set GetActiveUcs = SetOrthoUCS("Front")

Case "*BACK*"

Set GetActiveUcs = SetOrthoUCS("Back")

Case Else

Set GetActiveUcs = ThisDrawing.ActiveUCS 'current UCS is saved

End Select

End If

End Function

Public Function SetOrthoUCS(Optional strUcs As String = "Top") As AcadUCS

Dim dOrigin(2) As Double

Dim dXaxisPnt(2) As Double

Dim dYaxisPnt(2) As Double

'all the ucs' will originate from 0,0,0 as per the behavior in acad

Select Case strUcs

Case "Top"

dXaxisPnt(0) = 1: dXaxisPnt(1) = 0: dXaxisPnt(2) = 0

dYaxisPnt(0) = 0: dYaxisPnt(1) = 1: dYaxisPnt(2) = 0

Case "Bottom"

dXaxisPnt(0) = -1: dXaxisPnt(1) = 0: dXaxisPnt(2) = 0

dYaxisPnt(0) = 0: dYaxisPnt(1) = 1: dYaxisPnt(2) = 0

Case "Right"

dXaxisPnt(0) = 0: dXaxisPnt(1) = 1: dXaxisPnt(2) = 0

dYaxisPnt(0) = 0: dYaxisPnt(1) = 0: dYaxisPnt(2) = 1

Case "Left"

dXaxisPnt(0) = 0: dXaxisPnt(1) = -1: dXaxisPnt(2) = 0

dYaxisPnt(0) = 0: dYaxisPnt(1) = 0: dYaxisPnt(2) = 1

Case "Front"

dXaxisPnt(0) = 1: dXaxisPnt(1) = 0: dXaxisPnt(2) = 0

dYaxisPnt(0) = 0: dYaxisPnt(1) = 0: dYaxisPnt(2) = 1

Case "Back"

dXaxisPnt(0) = -1: dXaxisPnt(1) = 0: dXaxisPnt(2) = 0

dYaxisPnt(0) = 0: dYaxisPnt(1) = 0: dYaxisPnt(2) = 1

End Select

Set SetOrthoUCS = ThisDrawing.UserCoordinateSystems.Add(dOrigin, dXaxisPnt, dYaxisPnt, strUcs)

ThisDrawing.ActiveUCS = SetOrthoUCS

End Function