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