This works, finally. David the last part is mirror3d as Mick suggests.
Transpose rather than inverse threw for a while as usual (More brains reqd.)
There is a weird variety of math used here, but they all relate to normals somewhere.
Option Explicit
Const PI As Double = 3.14159265358979
Sub Dav()
Dim Ent As AcadEntity
Dim B As AcadBlock
Dim Br As AcadBlockReference
Dim P, M, M1, Ret
Dim Ms As AcadBlock
Dim Obj(0) As Object
Dim C1 As AcadCircle, C2 As AcadCircle
Dim R1 As AcadRegion
Dim sBlock As String
Dim Dist As Double, Ht As Double
Dim Util As AcadUtility
Dim Zero(2) As Double
Set Util = ThisDrawing.Utility
Set Ms = ThisDrawing.ModelSpace
sBlock = "5020760"
Util.GetEntity Ent, P, "Pick the 5020"
If Not TypeOf Ent Is AcadBlockReference Then Exit Sub
If Not Ent.Name = sBlock Then Exit Sub
Set Br = Ent
Set B = ThisDrawing.Blocks(sBlock)
For Each Ent In B
If TypeOf Ent Is AcadRegion Then
Set Obj(0) = Ent
Ret = ThisDrawing.CopyObjects(Obj, Ms)
Set R1 = Ret(0)
R1.Layer = "0"
R1.color = 2
Exit For
End If
Next Ent
Dist = Util.GetDistance(, "Centerline distance")
If Dist < 17.0855 Then
MsgBox ("Distance must be larger than 17")
Exit Sub
End If
Ht = (Dist - 17.0855) / Cos(15 / 180 * PI) + 4
M = BlockRefMatrix(Br)
M1 = Transpose(M)
R1.TransformBy (M1)
Dim Tube As Acad3DSolid
Set Tube = Ms.AddExtrudedSolid(R1, Ht, 0)
R1.Delete
Dim width As Double
Dim inspt(2) As Double
Dim Br2 As AcadBlockReference
width = (Tan(15 / 180 * PI) * (Dist - 17.0855)) + 4.0682
inspt(1) = -width: inspt(2) = -Dist
P = TransformPt2(M1, inspt)
Set Br2 = Ms.InsertBlock(Zero, "5141714", 1, 1, 1, 0)
Br2.Normal = Br.Normal
Br2.Rotation = Br.Rotation
Br2.Move Zero, P
End Sub
Function BlockRefMatrix(oBref As AcadBlockReference) As Variant
Dim V, M(3, 3) As Double, M1, M2
Dim j As Integer
Dim X, Y, Z, ins
Dim Rot As Double
Rot = oBref.Rotation
Z = oBref.Normal
V = GetOcsFromNormal(Z)
X = V(0): Y = V(1)
ins = oBref.InsertionPoint
M1 = RotZ(-Rot)
For j = 0 To 2
M(0, j) = X(j)
M(1, j) = Y(j)
M(2, j) = Z(j)
M(3, j) = ins(j)
Next j
M(3, 3) = 1
If Rot = 0 Then
BlockRefMatrix = M
Else
M2 = M4xM4(M, M1)
BlockRefMatrix = M2
End If
End Function
Function Transpose(Matrix As Variant) As Variant
Dim iCnt As Integer, jCnt As Integer
Dim transMat(0 To 3, 0 To 3) As Double
Dim I As Integer, j As Integer
iCnt = UBound(Matrix, 1)
jCnt = UBound(Matrix, 2)
For I = 0 To iCnt
For j = 0 To jCnt
transMat(I, j) = Matrix(j, I)
Next j
Next I
Transpose = transMat
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 GetOcsFromNormal(N As Variant) As Variant
'Arbitrary Axis Algorithm in dxf help
'N is the normal vector.
'Wy is the world Y axis, which is always (0,1,0).
'Wz is the world Z axis, which is always (0,0,1).
Dim Wy(2) As Double
Dim Wz(2) As Double
Dim Nx As Double, Ny As Double
Dim Ax, Ay, Ocs(1) 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
Ocs(0) = Ax
Ay = Crossproduct(N, Ax)
Ocs(1) = Ay
GetOcsFromNormal = Ocs
End Function
Function RotZ(Ang As Double) As Variant
'Rotate by an angle around the z axis
Dim M
Dim CosAng As Double, sinAng As Double
CosAng = Cos(Ang): sinAng = Sin(Ang)
M = IDMatrix
M(0, 0) = CosAng
M(0, 1) = -sinAng
M(1, 0) = sinAng
M(1, 1) = CosAng
RotZ = M
End Function
Function M4xM4(M1, M2) As Variant
'Matrix x matrix
Dim M(3, 3) As Double
Dim I As Integer, j As Integer
Dim k As Integer
Dim Sum As Double
For I = 0 To 3
For j = 0 To 3
For k = 0 To 3
Sum = Sum + M1(k, j) * M2(I, k)
Next k
M(I, j) = Sum
Sum = 0
Next j
Next I
M4xM4 = M
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 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
Function IDMatrix()
Dim M(3, 3) As Double
Dim I As Integer, j As Integer
M(0, 0) = 1
M(1, 1) = 1
M(2, 2) = 1
M(3, 3) = 1
IDMatrix = M
End Function