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.
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
Answer Verified By: Eduardo Mendoza
Hi Andrew,
Can you help me with this error when I try to run the code?
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, 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.
Hi Eduardo. Glad that worked for you. More than happy to help you out and Thanks you too.