Lisp code to vba code conversion

[jessicatyler0007]

Good Day,

Help me to convert lisp code into vba code, All experts are requested to help me.

;; Doug C. Broad, Jr.
;; can be used with vla-transformby to
;; transform objects from the UCS to the WCS
(defun UCS2WCSMatrix ()
  (vlax-tmatrix
    (append
      (mapcar
	'(lambda (vector origin)
	   (append (trans vector 1 0 t) (list origin))
	 )
	(list '(1 0 0) '(0 1 0) '(0 0 1))
	(trans '(0 0 0) 0 1)
      )
      (list '(0 0 0 1))
    )
  )
)
  
;; transform objects from the WCS to the UCS
(defun WCS2UCSMatrix ()
  (vlax-tmatrix
    (append
      (mapcar
	'(lambda (vector origin)
	   (append (trans vector 0 1 t) (list origin))
	 )
	(list '(1 0 0) '(0 1 0) '(0 0 1))
	(trans '(0 0 0) 1 0)
      )
      (list '(0 0 0 1))
    )
  )
)

;; UCS-BBOX (gile)
;; Returns the UCS coordinates of the object bounding box about UCS
;;
;; Argument
;; obj : a graphical object (ename or vla-object)
;;
;; Return
;; a list of left lower point and right upper point UCS coordinates

(defun ucs-bbox	(obj / space bb minpoint maxpoint line lst)
  (and (= (type obj) 'ENAME)
       (setq obj (vlax-ename->vla-object obj))
  )
  (vla-TransformBy obj (UCS2WCSMatrix))
  (setq bb (vla-getboundingbox obj 'minpoint 'maxpoint))
  (vla-TransformBy obj (WCS2UCSMatrix))
  (list
    (vlax-safearray->list minpoint)
    (vlax-safearray->list maxpoint)
  )
)

Thanks

[norman.yuan]

AutoCAD VBA (AutoCAD COM API) has built-in coordinate transform function: AcadUtility.TranslateCoordinates(). So, basically there is no need to convert the lisp code you provided.

In your case, you have a entity's bounding box, which is presented with 2 points (min point and max point). The 2 points' coordinates are in WCS. You want to know the 2 points' coordinates in current UCS. Following code shows how to call TranslateCoordinates():

Option Explicit

Public Sub GetEntityBoundingBox()

    Dim ent As AcadEntity
    Dim pt As Variant
    Dim maxPt As Variant
    Dim minPt As Variant
    
    On Error Resume Next
    
    ThisDrawing.Utility.GetEntity ent, pt, vbCrLf & "Select an entity:"
    If ent Is Nothing Then Exit Sub
    
    '' Get the entity's bounding box points, in WCS
    ent.GetBoundingBox minPt, maxPt
    ShowPoints "Coordinates in WCS", minPt, maxPt
    
    '' Get the entity's bounding box point, shown in Editor (UCS)
    maxPt = ThisDrawing.Utility.TranslateCoordinates(maxPt, acWorld, acUCS, 0)
    minPt = ThisDrawing.Utility.TranslateCoordinates(minPt, acWorld, acUCS, 0)
    ShowPoints "Coordinates in UCS", minPt, maxPt
    
End Sub

Private Sub ShowPoints(generalText As String, firstPt As Variant, secondPt As Variant)
    
    Dim maxText As String
    Dim minText As String
    
    maxText = vbTab & "First Point =>" & vbTab & "X: " & firstPt(0) & vbTab & "Y: " & firstPt(1)
    minText = vbTab & "Second Point ->" & vbTab & "X: " & secondPt(0) & vbTab & "Y: " & secondPt(1)
    
    MsgBox generalText & vbCrLf & vbCrLf & minText & vbCrLf & maxText
    
End Sub

[jessicatyler0007]

Many thanks for the replay.
I tested your code on another drawing but it is not showing the correct coordinates of lower left and upper top corner.
Please see the attached drawing and test the code on the drawing.

[jessicatyler0007]

@norman.yuan 

I request all experts, please help me to solve this.

ThisDrawing.SendCommand "_Rec" & vbCr & minPt(0) & "," & minPt(1) & vbCr & maxPt(0) & "," & maxPt(1) & vbCr

[norman.yuan · Accepted solution]

Sorry for getting this discussion back late because of being a bit busy in past a few days.

I misunderstood your question and thought you just want to know an entity's bounding box coordinates that converted to current UCS.

Now I know what you want is the "Bounding Box" with the entity's appearance in the UCS (thus the bounding box is different from the one calculated with its WCS coordinate with the VBA method AcadEntity.GetBoundingBox()). 

Because we need to call AcadEntity.GetBoundingBox() to get the max/min points of the bounding box, which is calculated based on the entity's WCS coordinates, so to do what you want, logically, is rather simple: transform the entity according to its UCS transformation IN WCS, so that the entity would appear in WCS as if it is in UCS. Then call AcadEntity.GetBoundingBox(), thus, we get the bounding box's max/min point coordinates with the values that are the same as if the entity's bounding box in UCS.

Well, while it is sounds simply, but with VBA, there are a couple of catches that makes things complicated:

1. Firstly, you need to get the UCS transform matrix. The catch is, if the current UCS is not saved (not named), the AcadUcs.GetUcsMatrix() returns wrong matrix. So, if the current UCS is not named, we need to save/name it and make it as ThisDrawing.ActiveUCS;

2. We must invert the UCS matrix before transform the entity. It is unfortunately, there is no existing VBA support to get inverse transform matrix (4 x 4 matrix). My work currently is doing AutoCAD .NET API, which provides enough Matrix calculation, and find it is frustrating that there is no easy way to invert the transform matrix. Fortunately, someone post VBA code in this forum years ago to do this inverting work here. (IMO, anyone who want to stick with Acad VBA for a while, should save this precious code!).

In my code example below, instead of transforming the entity with UCS matrix, and then transform it back after the calculation, I create a copy of the entity, transform it to get wanted coordinates, and then erase the copy. Here is the code:

Option Explicit

Public Sub GetUcsBoundungBox()

    Dim ucs As AcadUCS
    
    If ThisDrawing.GetVariable("UCSNAME") = "" Then
        '' current UCS is not saved, we must save it first
        With ThisDrawing
            Set ucs = .UserCoordinateSystems.Add( _
            .GetVariable("UCSORG"), _
            .GetVariable("UCSXDIR"), _
            .GetVariable("UCSYDIR"), _
            "OriginalUCS")
        End With
        ThisDrawing.ActiveUCS = ucs
        
    Else
        Set ucs = ThisDrawing.ActiveUCS  'current UCS is saved
    End If
    
    Dim ucsMatrix As Variant
    ucsMatrix = ucs.GetUCSMatrix
    
    '' Invert the UCS matrix
    Dim inverseMatrix(0 To 3, 0 To 3) As Double
    Dim inverseOk As Boolean
    inverseOk = InvertMatrix(ucsMatrix, inverseMatrix)
    If Not inverseOk Then
        MsgBox "Error"
        Exit Sub
    End If
    
    Dim ent As AcadEntity
    Dim entCopy As AcadEntity
    Dim pt As Variant
    
    On Error Resume Next
    ThisDrawing.Utility.GetEntity ent, pt, vbCr & "Pick entity:"
    If ent Is Nothing Then Exit Sub
    
    Set entCopy = ent.Copy()
    entCopy.ColorIndex = 2
    entCopy.TransformBy inverseMatrix
    
    Dim minPt As Variant
    Dim maxPt As Variant
    
    '' The entity's WCS bounding box
    ent.GetBoundingBox minPt, maxPt
    ShowPoints "Coordinates in WCS", minPt, maxPt
    
    '' The appeared bounding box in UCS
    entCopy.GetBoundingBox minPt, maxPt
    ShowPoints "Coordinates in UCS", minPt, maxPt
    
    entCopy.Delete
    
End Sub

Private Sub ShowPoints(generalText As String, firstPt As Variant, secondPt As Variant)
    
    Dim maxText As String
    Dim minText As String
    
    maxText = vbTab & "First Point =>" & _
        vbTab & "X: " & ThisDrawing.Utility.RealToString(firstPt(0), acDefaultUnits, 3) & _
        vbTab & "Y: " & ThisDrawing.Utility.RealToString(firstPt(1), acDefaultUnits, 3)
    minText = vbTab & "Second Point ->" & _
        vbTab & "X: " & ThisDrawing.Utility.RealToString(secondPt(0), acDefaultUnits, 3) & _
        vbTab & "Y: " & ThisDrawing.Utility.RealToString(secondPt(1), acDefaultUnits, 3)
    
    MsgBox generalText & vbCrLf & vbCrLf & minText & vbCrLf & maxText
    
End Sub

Here is the code to invert transform matrix (while one can directly get it from https://forums.autodesk.com/t5/vba/invert-a-transformation-matrix/m-p/11074048#M106055 , I still post it make make my reply complete):

Option Explicit
''https://forums.autodesk.com/t5/vba/invert-a-transformation-matrix/m-p/11074048#M106055
Public Function InvertMatrix(ByVal MatrixIn As Variant, ByRef MatrixOut As Variant) As Boolean
    ''## This code dervied from code found here:
    ''##  https://stackoverflow.com/questions/1148309/inverting-a-4x4-matrix
    ''##  Both of the above parameters are 4x4 arrays (0 to 3, 0 to 3)

    ''##  These just help with visibility/alignment by using a leading 'O' since i can't use leading zeroes...
    Dim O0 As Integer: O0 = 0
    Dim O1 As Integer: O1 = 1
    Dim O2 As Integer: O2 = 2
    Dim O3 As Integer: O3 = 3
    Dim O4 As Integer: O4 = 4
    Dim O5 As Integer: O5 = 5
    Dim O6 As Integer: O6 = 6
    Dim O7 As Integer: O7 = 7
    Dim O8 As Integer: O8 = 8
    Dim O9 As Integer: O9 = 9

    Dim m00 As Double: m00 = MatrixIn(0, 0)
    Dim m01 As Double: m01 = MatrixIn(0, 1)
    Dim m02 As Double: m02 = MatrixIn(0, 2)
    Dim m03 As Double: m03 = MatrixIn(0, 3)
    Dim m04 As Double: m04 = MatrixIn(1, 0)
    Dim m05 As Double: m05 = MatrixIn(1, 1)
    Dim m06 As Double: m06 = MatrixIn(1, 2)
    Dim m07 As Double: m07 = MatrixIn(1, 3)
    Dim m08 As Double: m08 = MatrixIn(2, 0)
    Dim m09 As Double: m09 = MatrixIn(2, 1)
    Dim m10 As Double: m10 = MatrixIn(2, 2)
    Dim m11 As Double: m11 = MatrixIn(2, 3)
    Dim m12 As Double: m12 = MatrixIn(3, 0)
    Dim m13 As Double: m13 = MatrixIn(3, 1)
    Dim m14 As Double: m14 = MatrixIn(3, 2)
    Dim m15 As Double: m15 = MatrixIn(3, 3)

    Dim inv(0 To 15) As Double
    Dim out(0 To 15) As Double
    Dim det As Double
    Dim i As Integer
    
    
    inv(O0) = 0 + (m05 * m10 * m15) - (m05 * m11 * m14) - (m09 * m06 * m15) + (m09 * m07 * m14) + (m13 * m06 * m11) - (m13 * m07 * m10)
    inv(O4) = 0 - (m04 * m10 * m15) + (m04 * m11 * m14) + (m08 * m06 * m15) - (m08 * m07 * m14) - (m12 * m06 * m11) + (m12 * m07 * m10)
    inv(O8) = 0 + (m04 * m09 * m15) - (m04 * m11 * m13) - (m08 * m05 * m15) + (m08 * m07 * m13) + (m12 * m05 * m11) - (m12 * m07 * m09)
    inv(12) = 0 - (m04 * m09 * m14) + (m04 * m10 * m13) + (m08 * m05 * m14) - (m08 * m06 * m13) - (m12 * m05 * m10) + (m12 * m06 * m09)
    inv(O1) = 0 - (m01 * m10 * m15) + (m01 * m11 * m14) + (m09 * m02 * m15) - (m09 * m03 * m14) - (m13 * m02 * m11) + (m13 * m03 * m10)
    inv(O5) = 0 + (m00 * m10 * m15) - (m00 * m11 * m14) - (m08 * m02 * m15) + (m08 * m03 * m14) + (m12 * m02 * m11) - (m12 * m03 * m10)
    inv(O9) = 0 - (m00 * m09 * m15) + (m00 * m11 * m13) + (m08 * m01 * m15) - (m08 * m03 * m13) - (m12 * m01 * m11) + (m12 * m03 * m09)
    inv(13) = 0 + (m00 * m09 * m14) - (m00 * m10 * m13) - (m08 * m01 * m14) + (m08 * m02 * m13) + (m12 * m01 * m10) - (m12 * m02 * m09)
    inv(O2) = 0 + (m01 * m06 * m15) - (m01 * m07 * m14) - (m05 * m02 * m15) + (m05 * m03 * m14) + (m13 * m02 * m07) - (m13 * m03 * m06)
    inv(O6) = 0 - (m00 * m06 * m15) + (m00 * m07 * m14) + (m04 * m02 * m15) - (m04 * m03 * m14) - (m12 * m02 * m07) + (m12 * m03 * m06)
    inv(10) = 0 + (m00 * m05 * m15) - (m00 * m07 * m13) - (m04 * m01 * m15) + (m04 * m03 * m13) + (m12 * m01 * m07) - (m12 * m03 * m05)
    inv(14) = 0 - (m00 * m05 * m14) + (m00 * m06 * m13) + (m04 * m01 * m14) - (m04 * m02 * m13) - (m12 * m01 * m06) + (m12 * m02 * m05)
    inv(O3) = 0 - (m01 * m06 * m11) + (m01 * m07 * m10) + (m05 * m02 * m11) - (m05 * m03 * m10) - (m09 * m02 * m07) + (m09 * m03 * m06)
    inv(O7) = 0 + (m00 * m06 * m11) - (m00 * m07 * m10) - (m04 * m02 * m11) + (m04 * m03 * m10) + (m08 * m02 * m07) - (m08 * m03 * m06)
    inv(11) = 0 - (m00 * m05 * m11) + (m00 * m07 * m09) + (m04 * m01 * m11) - (m04 * m03 * m09) - (m08 * m01 * m07) + (m08 * m03 * m05)
    inv(15) = 0 + (m00 * m05 * m10) - (m00 * m06 * m09) - (m04 * m01 * m10) + (m04 * m02 * m09) + (m08 * m01 * m06) - (m08 * m02 * m05)
        
    det = m00 * inv(O0) + _
          m01 * inv(O4) + _
          m02 * inv(O8) + _
          m03 * inv(12)
    
    If det = 0 Then
        InvertMatrix = False
    Else
        det = 1# / det
        For i = 0 To 15
            out(i) = inv(i) * det
        Next
    End If

    MatrixOut(0, 0) = out(0)
    MatrixOut(0, 1) = out(1)
    MatrixOut(0, 2) = out(2)
    MatrixOut(0, 3) = out(3)
    MatrixOut(1, 0) = out(4)
    MatrixOut(1, 1) = out(5)
    MatrixOut(1, 2) = out(6)
    MatrixOut(1, 3) = out(7)
    MatrixOut(2, 0) = out(8)
    MatrixOut(2, 1) = out(9)
    MatrixOut(2, 2) = out(10)
    MatrixOut(2, 3) = out(11)
    MatrixOut(3, 0) = out(12)
    MatrixOut(3, 1) = out(13)
    MatrixOut(3, 2) = out(14)
    MatrixOut(3, 3) = out(15)

    InvertMatrix = True
End Function

Hope this helps.

[jessicatyler0007]

I understand it sounds simple but was actually difficult to do, I don't know much about matrix calculations but I will definitely learn.

I sincerely thank you for giving your valuable time and helping me a lot.

At the moment this code is working perfectly, I have tested it on some other drawings. If any problem comes in future regarding this code, I hope you will help me.

Ones again thank you....

[ed57gmc]

If @norman.yuan solved your problem, please use the button to accept his solution.