3d Rotation of coordinates

[twa14]

3d Rotation of coordinates

The VBA code below rotates xyz coordinates in the cells B2 to D4 as an array about the xyz axes. The three Euler rotation angles are given in the cells
F2,G2,H2. The command:=RotpointsX(RotpointsY(RotpointsZ(AsArray($B2:$D4),$H2),$G2),$F2) carries out the rotation of the array about first the X then Y then Z axes. The command must be placed in cells J2:L4 with ctrl-shift-enter.
The rotated coordinates using this array command are found in cells J2:L4

My question is how can I change this code to allow the rotation angles given in F2,G2,H2 to be changed in row 3 , row 4 etc. In other words to enable each row of input coordinates to be rotated by different Euler angles for every row. The array function is probably not necessary as what I want is to take the coordinates per row in the columns B,C,D and using the angles in F,G,H output the rotated coordinates in J,K,L

Input Euler Angles Output
B C D F G H J K L
x y z tx ty tz x' y' z'
1 2 3 -0.3 -0.2 0.1 0.1834 2.9121 2.3422
1.1 1.9 2.5 0.3901 2.6882 1.9213
1.2 1.8 2.1 0.5769 2.4932 1.5940

VBA Code for above:


​

<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit; line-height: 12px;">Dim n As Integer
    n = UBound(pts, 1)
    If UBound(pts, 2) <> 3 Then
        'Need Three Points
        Exit Function
    End If
    Dim tX As Double, tY As Double, tZ As Double
    Dim X As Double, Y As Double, Z As Double

    For I = 1 To n
        tX = pts(I, 1): tY = pts(I, 2): tZ = pts(I, 3)
        X = tX
        Y = tY * Cos(angle_rad) - tZ * Sin(angle_rad)
        Z = tY * Sin(angle_rad) + tZ * Cos(angle_rad)
        pts(I, 1) = X: pts(I, 2) = Y: pts(I, 3) = Z
    Next I

    RotPointsX = pts
End Function
Public Function RotPointsY(ByRef pts() As Variant, angle_rad As Double) As Variant()
    Dim n As Integer
    n = UBound(pts, 1)
    If UBound(pts, 2) <> 3 Then
        'Need Three Points
        Exit Function
    End If
    Dim tX As Double, tY As Double, tZ As Double
    Dim X As Double, Y As Double, Z As Double

    For I = 1 To n
        tX = pts(I, 1): tY = pts(I, 2): tZ = pts(I, 3)
        X = tZ * Sin(angle_rad) + tX * Cos(angle_rad)
        Y = tY
        Z = tZ * Cos(angle_rad) - tX * Sin(angle_rad)
        pts(I, 1) = X: pts(I, 2) = Y: pts(I, 3) = Z
    Next I

    RotPointsY = pts
End Function
Public Function RotPointsZ(ByRef pts() As Variant, angle_rad As Double) As Variant()
    Dim n As Integer
    n = UBound(pts, 1)
    If UBound(pts, 2) <> 3 Then
        'Need Three Points
        Exit Function
    End If
    Dim tX As Double, tY As Double, tZ As Double
    Dim X As Double, Y As Double, Z As Double

    For I = 1 To n
        tX = pts(I, 1): tY = pts(I, 2): tZ = pts(I, 3)
        X = tX * Cos(angle_rad) - tY * Sin(angle_rad)
        Y = tX * Sin(angle_rad) + tY * Cos(angle_rad)
        Z = tZ
        pts(I, 1) = X: pts(I, 2) = Y: pts(I, 3) = Z
    Next I

    RotPointsZ = pts
End Function
'Next I need a function to convert a range into an array, and the easiest way to do this with this function:
Public Function AsArray(ByVal r_pts As Range) As Variant()
    AsArray = r_pts.Value2
End Function</code>

 

[Worf]

Is this what you want?

Public Function RotPointsX(ByRef pts(), angle_rad As Double) As Variant()
Dim n As Integer, i%, tX As Double, tY As Double, tZ As Double, X As Double, Y#, Z#
    n = UBound(pts, 1)
    If UBound(pts, 2) <> 3 Then ' need 3 points
        Exit Function
    End If
    For i = 1 To n
        tX = pts(i, 1): tY = pts(i, 2): tZ = pts(i, 3)
        X = tX
        Y = tY * Cos(angle_rad) - tZ * Sin(angle_rad)
        Z = tY * Sin(angle_rad) + tZ * Cos(angle_rad)
        pts(i, 1) = X: pts(i, 2) = Y: pts(i, 3) = Z
    Next
    RotPointsX = pts
End Function


Public Function RotPointsY(ByRef pts(), angle_rad As Double) As Variant()
    Dim n As Integer, i%, tX As Double, tY As Double, tZ As Double, X As Double, Y#, Z#
    n = UBound(pts, 1)
    If UBound(pts, 2) <> 3 Then Exit Function
    For i = 1 To n
        tX = pts(i, 1): tY = pts(i, 2): tZ = pts(i, 3)
        X = tZ * Sin(angle_rad) + tX * Cos(angle_rad)
        Y = tY
        Z = tZ * Cos(angle_rad) - tX * Sin(angle_rad)
        pts(i, 1) = X: pts(i, 2) = Y: pts(i, 3) = Z
    Next
    RotPointsY = pts
End Function


Public Function RotPointsZ(ByRef pts() As Variant, angle_rad As Double) As Variant()
    Dim tX As Double, tY As Double, tZ As Double, i%, X As Double, Y As Double, Z#, n%
    n = UBound(pts, 1)
    If UBound(pts, 2) <> 3 Then Exit Function
    For i = 1 To n
        tX = pts(i, 1): tY = pts(i, 2): tZ = pts(i, 3)
        X = tX * Cos(angle_rad) - tY * Sin(angle_rad)
        Y = tX * Sin(angle_rad) + tY * Cos(angle_rad)
        Z = tZ
        pts(i, 1) = X: pts(i, 2) = Y: pts(i, 3) = Z
    Next
    RotPointsZ = pts
End Function

Public Function AsArray(ByVal r_pts As Range) As Variant()
    AsArray = r_pts.Value2
End Function

Function Rot3D(ByVal rng1 As Range, ByVal rng2 As Range, ByVal rng3 As Range, ByVal rng4 As Range)
Rot3D = RotPointsX(RotPointsY(RotPointsZ(AsArray(rng1), rng2.Value), rng3.Value), rng4.Value)
End Function

 

[twa14]

Hi Worf and thanks for replying.

There is an error in my text above, I tried to correct it but I have no editing rights. The text should read:

Input Euler Angles Output
B C D F G H J K L
x y z tx ty tz x' y' z'
1.0 2.0 3.0 -0.3 -0.2 0.1 0.1834 2.9121 2.3422
1.1 1.9 2.5 -0.3 -0.2 0.1 0.3901 2.6882 1.9213
1.2 1.8 2.1 -0.3 -0.2 0.1 0.5769 2.4932 1.5940

The input coordinates are in cells B2 C2 D2 (and down), The rotation angles in cells F2 G2 H2 (and down) (the angles are the same in the rows under row 2, these will change once the sheet is working correctly). The rotated coordinates are in cells J2 K2 L2 (and down). I tried using your addition to the code and the formula's as indicated in your post above but get #VALUE errors in all the cells, probably because of the errors in my original post, apologies for that.

 

[Worf]

Note that the array formulas are entered at J2:L2, J3:L3 and J4:L4. Would you like a link to my test workbook?

 

[twa14]

Hi Worf

That worked beautifully, many thanks, i won't need the link to your sheet as its working on my own sheet. As you probably noticed, VBA is not my thing although I keep trying to "get into" it.
I took the original code from Stack Exchange so I will be placing the amended code with comments back on the Stack Exchange link.

Again many thanks,

Regards

Tom Walsh

 

[Worf]

You are welcome and thanks for the feedback.