Is there a macro that will rotate a cell to align with another cell? We used to be able to do this by using the JNC code in Survey with InRoads.

Question

We would like to have a macro that will locate the GPG Cell (Gate Post Gate) and then search within a given distance for a GP Cell (Gate Post). Then calculate the rotation angle between the cells and apply the rotation angle to the GPG Cell. The image below shows a non existent yellow line, included for clarity . 
 The SmartObjects.mvba that is delivered with OpenRoads performs a similar function that rotates a cell to a linear element. Mostly used for rotating sign cells and telephone posts.

Andrew D&#39;Sylva · Accepted Answer

I did find the SmartObjects.mvba located here under Survey 
 
 I had some code to work with cells so I created one to do Eduardo's task. 
 I'm using a mailbox cell and a water tank cell from my DOT's cell library. The program rotates the mailbox to point towards the water tank. The water tanks must be within 50ft of the mailbox. Here's the code. 
 Sub CellRotateFromCell2()
 Dim ee As ElementEnumerator
 Dim ee2 As ElementEnumerator
 Dim sc As New ElementScanCriteria
 
 Dim ogCell As CellElement
 Dim ogCell2 As CellElement
 
 Dim dAngle As Double
 Dim dDist As Double
 Dim dDistMax As Double
 
 Dim sCellRotate As String
 Dim sCellRotateTo As String
 
 Dim sname As String
 Dim sName2 As String

dDistMax = 50#
 sCellRotate = "TP_MM_Mailbox"
 sCellRotateTo = "TP_MM_WaterTank"
 
 sc.ExcludeAllTypes
 sc.IncludeType msdElementTypeSharedCell
 sc.IncludeType msdElementTypeCellHeader
 sc.IncludeOnlyCell sCellRotate
 Set ee = ActiveModelReference.Scan(sc)

sc.ExcludeAllTypes
 sc.IncludeType msdElementTypeSharedCell
 sc.IncludeType msdElementTypeCellHeader
 sc.IncludeOnlyCell "TP_MM_WaterTank"
 Set ee2 = ActiveModelReference.Scan(sc)

If ee Is Nothing Then
 Debug.Print "ActiveModelReference.GetSelectedElements returned nothing"
 Else
 Do While ee.MoveNext
 If ee.Current.IsCellElement Then
 Set ogCell = ee.Current.AsCellElement
 sname = ogCell.Name
 If sname = "" Then
 sname = "blank"
 End If
 Debug.Print ("Cell " + sname + "," + rtos(ogCell.Scale.x, 2) + "," + rtos(ogCell.Origin.x, 2) + "," + rtos(ogCell.Origin.Y, 2) + "," + rtos(ogCell.Origin.Z, 2))

If ee2 Is Nothing Then
 Debug.Print "ActiveModelReference.GetSelectedElements returned nothing"
 Else
 ee2.Reset
 Do While ee2.MoveNext
 If ee2.Current.IsCellElement Then
 Set ogCell2 = ee2.Current.AsCellElement
 sname = ogCell2.Name
 If sname = "" Then
 sname = "blank"
 End If
 dDist = djv_distance(ogCell.Origin, ogCell2.Origin)
 If dDist < dDistMax Then
 dAngle = djv_angle(ogCell.Origin, ogCell2.Origin)
 ogCell.Rotate ogCell.Origin, 0, 0, dAngle
 ogCell.Rewrite
 Debug.Print ("Cell " + sname + "," + rtos(dDist, 2) + "," + rtos(dAngle, 4) + "," + rtos(ogCell.Origin.x, 2) + "," + rtos(ogCell.Origin.Y, 2) + "," + rtos(ogCell.Origin.Z, 2))
 End If
 End If
 Loop
 End If
 End If
 Loop
 End If

Set ph = Nothing
 Set ogCell = Nothing
 Set osCell = Nothing
 
End Sub

Function djv_angle(c1 As Point3d, c2 As Point3d) As Double
 Dim dx As Double
 Dim dy As Double
 Dim ang As Double
 
 dx = c2.x - c1.x
 dy = c2.Y - c1.Y
 
 If dx = 0 Then
 If dy > 0 Then
 djv_angle = 0.5 * PI
 Else
 djv_angle = -0.5 * PI
 End If
 Else
 ang = Atn(Abs(dy / dx))
 If dy < 0 Then
 If dx < 0 Then
 ang = ang + PI
 Else
 ang = 2 * PI - ang
 End If
 ElseIf dx < 0 Then
 ang = PI - ang
 End If
 djv_angle = ang
 End If
End Function

Function djv_distance(c1 As Point3d, c2 As Point3d) As Double
 Dim dx As Double
 Dim dy As Double
 dx = c2.x - c1.x
 dy = c2.Y - c1.Y
 djv_distance = Sqr(dx ^ 2 + dy ^ 2)
End Function
 
 Just set the 3 variables below to your case. You could create a dialog box to set these variables. 
 dDistMax = 50# sCellRotate = "TP_MM_Mailbox" sCellRotateTo = "TP_MM_WaterTank" 
 
 Here are a before and after shots testing my code. The circles are 50ft radius. 
 Before

After

Hope this helps. 
 Regards, 
 Andrew

Andrew D&#39;Sylva · Answer

Hi Eduardo, 
 Forgot to include that function plus one other. Here they are. 
 Public Function SepStr(cNum As Integer, str As String, Sep As String)
 Dim Sep_Length As Long
 Dim Str_Length As Long
 Dim startpos1 As Integer, StartPos2 As Integer
 Dim count As Integer
 
 SepStr = ""
 If str = "" Then GoTo NoString
 Sep_Length = Len(Sep)
 Str_Length = Len(str)
 
 startpos1 = 1
 StartPos2 = 1
 
 count = 0
 While count < cNum
 If StartPos2 > 1 Then startpos1 = StartPos2 + Sep_Length
 StartPos2 = InStr(startpos1, str, Sep, 1)
 If StartPos2 = 0 Then StartPos2 = Str_Length + 1
 If Sep = " " And startpos1 = StartPos2 Then
 Else
 count = count + 1
 End If
 Wend
 If startpos1 > StartPos2 Then
 SepStr = ""
 Else
 SepStr = Mid(str, startpos1, StartPos2 - startpos1)
 End If
NoString:
End Function

Public Function rtos(r As Double, nPrec As Integer) As String
 Dim s As String
 Dim str As String
 Dim j As Integer
 
 s = Round(r, nPrec)
 str = SepStr(2, s, ".")
 If str = "" And nPrec > 0 Then
 s = s + "."
 End If
 For j = nPrec - 1 To Len(str) Step -1
 s = s + "0"
 Next j
 
 rtos = s
End Function
 
 Hopefully that covers it. 
 Thanks, 
 Andrew

Eduardo Mendoza · Answer

Andrew, Thanks again! This works now. I just have to adjust it for different scenarios within our Survey data but this will definitely work out. This is way more help than I expected. I truly appreciate you.

Is there a macro that will rotate a cell to align with another cell? We used to be able to do this by using the JNC code in Survey with InRoads.

Top Replies