3d Rotation of coordinates

twa14

New Member
Joined
Feb 9, 2018
Messages
8
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:
<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>
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Is this what you want?

dVgW9q7.png


Code:
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
 
Upvote 0
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.
 
Upvote 0
Note that the array formulas are entered at J2:L2, J3:L3 and J4:L4. Would you like a link to my test workbook?

2SzzJJd.jpg
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,223,315
Messages
6,171,410
Members
452,399
Latest member
oranges

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top