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.

Hi Eduardo,

I do not recall any such macro available, the requirement to be able to locate a particular cell makes the requirement specific.

Usine AccuDraw, it's simple to rotate the cell when it is placed, but to modify existing cells, I guess macro must be created.

With regards,

  Jan

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

Thanks for doing this Andrew! I will test later this week and let you know how it goes. I really do appreciate this.

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