VBA to interface with civil reports?

Dustin Powell — Thu, 05 May 2022 20:08:35 GMT

i'm wanting to pull some values from the civil reports to be used in a VBA program inside OpenRoads. i know the files are routed to the appdata\local\temp but i cant track the latest file name other than actually looking into the folder.

is there a way i can capture the .xml file name as its created or is there a means for me to redirect the save folder for the report when my code runs?

if i can redirect it only when the code runs i can have it delete the file at the end of the code run

VBA feature macros in OpenSite Designer

Jan Šalom — Thu, 06 Oct 2022 08:31:09 GMT

The same question as https://communities.bentley.com/products/programming/civil_programming/f/civil_programming_forum/168912/vba-feature-macros-in-ord but for OpenSite Designer. Is it possible to work with terrain model objects in OpenSite Designer and if so where is the library file.

Ask A Question II

Thu, 01 Sep 2022 18:06:05 GMT

Ask 10 questions in a forum.

Discussion Starter I

Thu, 21 Jul 2022 21:53:37 GMT

Start a discussion in a forum that receives 5 replies.

ORD 2021 R1 VBA DLL Reference for Trace Slope Command or Any Terrain point command?

Dustin Powell — Thu, 09 Jun 2022 18:35:50 GMT

So i am unfortunately unable to use the SDK to read or program in C due to the company i work for.

I have been using VBA to try to make the trace slope command more automated the hangup is getting a point from the boundary of the surface or getting a command state return from the trace slope command to make sure a terrain has been selected.

i could potentially work around this by patterning the border and getting vertices back but that seems like a resource intensive means.

Attempts to use locate element by scanning are somewhat successful but limited in returning a value thats actually on the border of the terrain. i can get range.low and range.high but thats about it.

prerequisite for code is a station offset report to have been run prior to use.

Special thanks to LA Solutions for the scanbylevel i modified here.

Option Explicit
Option Compare Text
Public Sub ItterativeTraceSlope()
Call GetArrayData
End Sub

Private Sub GetArrayData()

'requires microsoft scripting runtime library reference
'requires microsoft excel 16.0 object library reference
'this section gets the station offset report and saves it to an array removing unneeded text

    Dim MyArray() As Variant
    Dim Data As Variant
    Dim userresult As Variant
    Dim myPath, myFile, DGNFile, NewestFile, PointText, Trackr, Tailend As String
    Dim c As Long, N, erCatch, intval As Integer
    Dim LatestDate As Date, OLDDate As Date
    Dim LMD As Date, maxd As Long
    
    
  DGNFile = "*" & ActiveDesignFile.Path & "*" 'get the folder path for the project from the dgn
  OLDDate = DateAdd("m", -3, Date) 'skip files older than 90 days
    myPath = Environ$("TEMP") 'file path of xml report
    'Debug.Print myPath & "is this where xml file is?"
    If Right(myPath, 1) <> "\" Then myPath = myPath & "\"
    myFile = Dir(myPath & "*.xml", vbNormal) 'limit to xml only files
    If Len(myFile) = 0 Then 'no xmls in that folder
        MsgBox "No files were found! Please Run Station Offset Report", vbExclamation
        Exit Sub
    End If
Do While Len(myFile) > 0
        LMD = FileDateTime(myPath & myFile)
    If LMD < OLDDate Then 'skip files older than 90 days
     GoTo LP:
     End If
        'check file for tag
        Open myPath & myFile For Input As #1 'open and read the first three lines of each xml file
    For N = 1 To 3 'this section checks the xml file to make sure it matches the command station offset and is from the same project as the dgn.
   
       Line Input #1, Data
        
            Select Case True
            'is file a station offset report?
            Case Data Like "*Station Offset Report*"
            'go to next line of file then
            Line Input #1, Data
           'Debug.Print Data 'does file tag match dgnfile path
            If Data Like DGNFile Then
            If LMD > LatestDate Then 'check the date
            NewestFile = myFile
            LatestDate = LMD
            End If
            End If
            End Select
    Next
   Close #1
        myFile = Dir
LP:
   
Loop
    
     If Len(NewestFile) = 0 Then 'no file matching end process
        MsgBox "No files were found for this project. Please Run Station Offset Report", vbExclamation
        Exit Sub
    End If

    Open myPath & NewestFile For Input As #1
    'Debug.Print "file opened" & NewestFile
    erCatch = 0
    c = 1
    Do Until EOF(1)
        Line Input #1, Data
        Select Case True
            'use trackr to find values to pass to array
            Case Data Like "*<offsetLinePoint*" 'change this to the line just before your desired capture
                Trackr = "Process" 'value to make sure we are only getting the areas we want in each loop
                erCatch = 1 'value to see if data exists
            
            Case Data Like "*<point*" And Trackr = "Process"
                                'remove and replace text ; delineated
                PointText = excel.WorksheetFunction.Substitute(Data, "<point", "")
                PointText = excel.WorksheetFunction.Substitute(PointText, ">", "")
                PointText = excel.WorksheetFunction.Substitute(PointText, "northing=", ";") 'ycoordinate
                PointText = excel.WorksheetFunction.Substitute(PointText, "easting=", ";") 'xcoordinate
                PointText = excel.WorksheetFunction.Substitute(PointText, "elevation=", ";") 'zcoordinate
                'locate and replace pointless text at end of string
                Tailend = Mid(PointText, InStr(1, PointText, "pointType"), Len(PointText) + 1 - InStr(1, PointText, "pointType"))
                PointText = excel.WorksheetFunction.Substitute(PointText, Tailend, "")
                ''Debug.Print PointText
                PointText = excel.WorksheetFunction.Substitute(PointText, Chr(34), "") 'remove quotes
                PointText = Trim(PointText)
                If IsNumeric(PointText) Then PointText = Val(PointText)
                ReDim Preserve MyArray(1, 1 To c) 'expand the array for each new point
                'Debug.Print PointText
                MyArray(1, c) = PointText 'save each point to the array
                'reset or continue counting
                Trackr = ""
                c = c + 1
           
        End Select
    Loop
    
    Close #1 'close the file
    'Debug.Print "file closed"
    If erCatch = 0 Then  'didnt find anything
    MsgBox "No data Found"
    Exit Sub
    End If
 
  maxd = MAXd2POINT(MyArray) 'call maxd function and get largest distance
  
RESTRT:
userresult = excel.Application.InputBox("Enter Distance Interval (25'Min)(" & maxd & "Max):", "Trace Slope Iterations", "25", , , , , 1) 'change "25" if you want a new default

If userresult = "False" Then
Exit Sub 'user hit cancel end program

ElseIf Not IsNumeric(userresult) Or userresult < 25 Then 'change this section if you want a different minimum
MsgBox "Value must be a number and no less than 25"
GoTo RESTRT:
ElseIf userresult > 25 Then 'user input is greater than 25 we will round and use 5' intervals because i said so.
userresult = userresult / 5
userresult = excel.WorksheetFunction.Floor_Math(userresult, 1) * 5
intval = userresult
End If
   'pass variables to next sub command
    ''SaveArrayToTextFile myPath, MyArray'uncomment to save text file
    TraceSlopeArray MyArray, intval
    'MyArray = Application.WorksheetFunction.Transpose(MyArray)
        'Range("A1").Resize(UBound(MyArray, 1), UBound(MyArray, 2)) = MyArray 'excel output
End Sub
Private Sub TraceSlopeArray(MyArray2 As Variant, DistInt As Integer)
'this section takes the previous array and passes it to the command trace slope
'debug.print "Made it to TraceSlopeArray"
    Dim startpoint, point1 As Point3d
    Dim point2, pointP As Point3d
    Dim SPArray() As String, N, L As Integer
    Dim lngTemp, distcal As Long, Tim, lvlName As String
    Dim Vi, Fi As Integer
'loop check for 3d if not 3d call 3d
Fi = 0
Vi = 0
 While Fi = 0 And Vi < 9
 Vi = Vi + 1
    If ActiveDesignFile.Views(Vi).IsOpen = True Then
     ActiveDesignFile.Views(Vi).Select
     If ActiveModelReference.Is3D = True Then
     Fi = 1
     Debug.Print Vi & "is 3d"
     End If
    End If

Wend

If Fi = 0 Then
    'no 3d found call 3d command
    CadInputQueue.SendKeyin "vba Run TwoView3DF9"
    Vi = 2
End If
 
 'send levels to scanner functions to find the terrain model and get startpoint
lvlName = "SV_DTM_TERRAIN MODEL"
startpoint = ScanByLevelGetSurfacePoint(lvlName)

'   Coordinates are in master units
 'get start point from user cause i couldnt find anything
'Call GETUSERPNT(startPoint)
If startpoint.X = "" Then
Exit Sub
End If

'   Send a keyin to start traceslope and set feature definition
    CadInputQueue.SendKeyin "DMSG ACTIVATETOOLBYPATH Terrain Model Tools\Analyze Trace Slope"
     CadInputQueue.SendKeyin "CIVILCMD SETVALUE FeatureDefinition=<FeatureDefinition>Bentley.CifNET.GeometryModel.ContentManagement.SlopeTraceObjectSettings, Bentley.CifNET.GeometryModel.4.0, Version=1.0.0.0, Culture=neutral, PublicKeyToken=4bf6c96a266e58d4|TraceSlope\Roadway\Trace Slope\Trace Slope|False</FeatureDefinition> "

    'CadInputQueue.SendKeyin "CIVILCMD SETVALUE FeatureDefinition=<FeatureDefinition>Bentley.CifNET.GeometryModel.ContentManagement.SlopeTraceObjectSettings, Bentley.CifNET.GeometryModel.4.0, Version=1.0.0.0, Culture=neutral, PublicKeyToken=4bf6c96a266e58d4|No Feature Definition|False</FeatureDefinition> "

    CadInputQueue.SendKeyin "CIVILCMD SETVALUE NamePrefix=<NamePrefix>VAByAGEAYwBlACAAUwBsAG8AcABlAA==,False</NamePrefix> "

    'CadInputQueue.SendKeyin "CIVILCMD SETVALUE FeatureDefinition=<FeatureDefinition>Bentley.CifNET.GeometryModel.ContentManagement.SlopeTraceObjectSettings, Bentley.CifNET.GeometryModel.4.0, Version=1.0.0.0, Culture=neutral, PublicKeyToken=4bf6c96a266e58d4|TraceSlope\Roadway\Trace Slope\Trace Slope|False</FeatureDefinition> "

'   Send the start point to the current command
    point1.X = startpoint.X
    point1.Y = startpoint.Y
    point1.Z = startpoint.Z
    CadInputQueue.SendDataPoint point1, Vi
    
    
'   lets get points from the array
     For N = 1 To UBound(MyArray2, 2)
    'preserve each previous point for distance calcs
    pointP.X = point1.X
    pointP.Y = point1.Y
  
    'split that array to points and segment x,y,z
    Tim = MyArray2(1, N)
    SPArray = Split(Tim, ";")
    point1.X = Trim(SPArray(2)) 'x coordinate is 2nd value
    point1.Y = Trim(SPArray(1)) 'y coordinate is 1st value
    point1.Z = Trim(SPArray(3)) 'z is elevation and doesnt really matter
    'figure out the distance between points
    distcal = ((pointP.X - point1.X) ^ 2 + (pointP.Y - point1.Y) ^ 2) ^ 0.5
    If distcal < DistInt And N < UBound(MyArray2, 2) Then
     L = N 'pass N number to L
    Do Until distcal > DistInt 'loop until the distance is greater than the minimum interval
    Tim = MyArray2(1, L)
    SPArray = Split(Tim, ";")
    point1.X = Trim(SPArray(2))
    point1.Y = Trim(SPArray(1))
    point1.Z = Trim(SPArray(3))
    distcal = ((pointP.X - point1.X) ^ 2 + (pointP.Y - point1.Y) ^ 2) ^ 0.5
    L = L + 1
    If L > UBound(MyArray2, 2) Then 'reached the end of the array go back 1 and leave the loop
    N = L - 1
    Exit Do
    End If
    Loop
    N = L 'Pass L to N number

    End If
    
    point1.X = Trim(SPArray(2))
    point1.Y = Trim(SPArray(1))
    point1.Z = Trim(SPArray(3))
    
    'send point to command in 3d view
    CadInputQueue.SendDataPoint point1, Vi
    'Debug.Print point1.X

    CadInputQueue.SendKeyin "CIVILCMD SETVALUE FeatureDefinition=<FeatureDefinition>Bentley.CifNET.GeometryModel.ContentManagement.SlopeTraceObjectSettings, Bentley.CifNET.GeometryModel.4.0, Version=1.0.0.0, Culture=neutral, PublicKeyToken=4bf6c96a266e58d4|TraceSlope\Roadway\Trace Slope\Trace Slope|False</FeatureDefinition> "

    CadInputQueue.SendKeyin "CIVILCMD SETVALUE NamePrefix=<NamePrefix>VAByAGEAYwBlACAAUwBsAG8AcABlAA==,False</NamePrefix> "

    Next
    
    

'   Send a reset to the current command
    CadInputQueue.SendReset

    CadInputQueue.SendKeyin "CIVILCMD SETVALUE FeatureDefinition=<FeatureDefinition>Bentley.CifNET.GeometryModel.ContentManagement.SlopeTraceObjectSettings, Bentley.CifNET.GeometryModel.4.0, Version=1.0.0.0, Culture=neutral, PublicKeyToken=4bf6c96a266e58d4|TraceSlope\Roadway\Trace Slope\Trace Slope|False</FeatureDefinition> "

    CadInputQueue.SendKeyin "CIVILCMD SETVALUE NamePrefix=<NamePrefix>VAByAGEAYwBlACAAUwBsAG8AcABlAA==,False</NamePrefix> "

    CadInputQueue.SendReset

    CommandState.StartDefaultCommand
    'debug.print "traceSlopeArray Successful"
    
End Sub
Public Function ScanByLevelGetSurfacePoint(levelName As String) As Point3d
'this section checks the current dgn levels for a terrain surface
'debug.print "Made it to ScanByLevelGetSurfacePoint"
    Dim nElements As Long
    Dim idf2, crp2 As String, pnt2 As Point3d
    Dim oLevel As Level
    Dim lvlres1 As Boolean

nElements = 0

crp2 = "Coversheet"
    
CH2:

'Debug.Print OAtt.AttachName
lvlres1 = IsValidLevelName(levelName, ActiveModelReference)
If lvlres1 = False Then
GoTo OtherLevels1:
End If
    Set oLevel = ActiveModelReference.Levels(levelName)
    'check if level exists
    
    '   Set up scan criteria
    Dim oScanCriteria   As ElementScanCriteria
    Set oScanCriteria = New ElementScanCriteria
    oScanCriteria.ExcludeAllLevels
    oScanCriteria.IncludeLevel oLevel 'only the level named
    oScanCriteria.ExcludeNonGraphical
    '   Perform the scan
    Dim oEnumerator As ElementEnumerator
    Set oEnumerator = ActiveModelReference.Scan(oScanCriteria)
Do While oEnumerator.MoveNext
    If oEnumerator.Current.IsGraphical Then 'redundant but if not something is wrong
        oEnumerator.Current.Redraw msdDrawingModeHilite
        idf2 = DLongToString(oEnumerator.Current.ID)
    If Not idf2 = "" Then 'no ID no Entry
        pnt2 = oEnumerator.Current.Range.Low
        nElements = nElements + 1
        crp2 = "have you seen my stapler?"
    End If
    End If
Loop

OtherLevels1:
      'if at first you dont succeed try a few more levels
    If crp2 = "Coversheet" And Not levelName Like "RDY_*" Then
    levelName = "RDY_Existing Ground"
    GoTo CH2:
    ElseIf crp2 = "Coversheet" And Not levelName Like "RDY_DTM_PERIMETER" Then
    levelName = "RDY_DTM_PERIMETER"
    GoTo CH2:
    ElseIf crp2 = "Coversheet" And levelName = "RDY_DTM_PERIMETER" Then
    'Debug.print "Couldnt find anything in the DGN Check References"
    levelName = "SV_DTM_TERRAIN MODEL"
    pnt2 = ScanByLevelGetSurfPointAttach(levelName)
    
    End If
    
    ScanByLevelGetSurfacePoint = pnt2
    ''Debug.Print idf2 & ";" & crp2 & ";"
    'debug.print "ScanByLevelGetSurfacePoint Successful"
End Function
Public Function ScanByLevelGetSurfPointAttach(levelName2 As String) As Point3d
'this section checks attachment references will only use files whose names are Existing or Terrain
    'debug.print "made it to ScanByLevelGetSurfPointAttach"
    Dim nElements As Long
    Dim idf2, crp2 As String, pnt2 As Point3d
      Dim lvlres2 As Boolean
nElements = 0
    
    Dim oLevel2 As Level
crp2 = "Coversheet"
    
CH2:
Dim OAtt As Attachment
'loop though all attachments
For Each OAtt In ActiveModelReference.Attachments
'can we find attachement names
If OAtt.AttachName Like "*Exist*" Or OAtt.AttachName Like "*Terrain*" Then
'Debug.Print OAtt.AttachName
lvlres2 = IsValidLevelName(levelName2, OAtt)
If lvlres2 = False Then
GoTo OtherLevels2:
End If
    Set oLevel2 = OAtt.Levels(levelName2)
    'check if level exists
   
    '   Set up scan criteria
    Dim oScanCriteria   As ElementScanCriteria
    Set oScanCriteria = New ElementScanCriteria
    oScanCriteria.ExcludeAllLevels
    oScanCriteria.IncludeLevel oLevel2
    oScanCriteria.ExcludeNonGraphical
    '   Perform the scan
    Dim oEnumerator As ElementEnumerator
    Set oEnumerator = OAtt.Scan(oScanCriteria)
Do While oEnumerator.MoveNext
    If oEnumerator.Current.IsGraphical Then 'redundant but if not something is wrong

 
        oEnumerator.Current.Redraw msdDrawingModeHilite
        idf2 = DLongToString(oEnumerator.Current.ID)
    If Not idf2 = "" Then 'no ID no Entry
        pnt2 = oEnumerator.Current.Range.Low
        nElements = nElements + 1
        crp2 = "have you seen my stapler?"
    End If
    End If
Loop

OtherLevels2:
    'if at first you dont succeed try a few more levels
    If crp2 = "Coversheet" And Not levelName2 Like "RDY_*" Then
    levelName2 = "RDY_Existing Ground"
    GoTo CH2:
    ElseIf crp2 = "Coversheet" And Not levelName2 Like "RDY_DTM_PERIMETER" Then
    levelName2 = "RDY_DTM_PERIMETER"
    GoTo CH2:
    ElseIf crp2 = "Coversheet" And levelName2 = "RDY_DTM_PERIMETER" Then
    MsgBox "NO Terrain Model Found, Check Terrain Feature Definition"
    'debug.print "what the hey we checked references and didnt find it either?"
    Exit Function
    End If
    
End If
Next

    ScanByLevelGetSurfPointAttach = pnt2
    'Debug.Print pnt2.X & ";" & crp2 & ";"
    'debug.print "ScanByLevelGetSurfPointAttach Sucessful"
End Function

Public Function MAXd2POINT(Myarray3 As Variant) As Long
'checks the max distance between first and last entry of array
'debug.print "made it to MAXd2POINT"
    Dim Pmin As Point2d, Pmax As Point2d
    Dim PArray() As String, TinyT As String
    Dim c As Integer, mxd As Double
c = UBound(Myarray3, 2)
TinyT = Myarray3(1, 1)
    PArray = Split(TinyT, ";")
    Pmin.X = Trim(PArray(2))
    Pmin.Y = Trim(PArray(1))
  TinyT = Myarray3(1, c)
    PArray = Split(TinyT, ";")
    Pmax.X = Trim(PArray(2))
    Pmax.Y = Trim(PArray(1))
 mxd = Point2dDistance(Pmin, Pmax) / 5
 mxd = excel.WorksheetFunction.Floor_Math(mxd, 1) * 5
MAXd2POINT = mxd
'debug.print "MAXd2POINT Sucessful " & mxd
End Function
Public Function IsValidLevelName(ByVal lvlName2 As String, omodref As ModelReference) As Boolean
    IsValidLevelName = False
    On Error GoTo err_IsValidLevelName
    Dim oLevel3                              As Level
    Set oLevel3 = omodref.Levels(lvlName2)
    If oLevel3 Is Nothing Then
        IsValidLevelName = False
    Else
        IsValidLevelName = True
    End If
    Set oLevel3 = Nothing
    Exit Function

err_IsValidLevelName:
    Select Case Err.Number
    Case 5:
        '   Level not found
        Resume Next
    Case Else
        MsgBox "IsValidLevelName failed"
    End Select
End Function
Sub SaveArrayToTextFile(myPath2 As String, MyArray2 As Variant)
'this is fairly obvious write array to text
    Dim FSO As New FileSystemObject
    Dim filetocreate As Object
    Dim N As Integer
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
    Set filetocreate = FSO.CreateTextFile(myPath2 & "test.txt")
 ''Debug.Print MyArray2(1, 23)
    For N = 1 To UBound(MyArray2, 2)
        filetocreate.WriteLine MyArray2(1, N)
    Next
    
    filetocreate.Close
 
End Sub

Exporting Terrain Model

Juho Selenius — Tue, 08 Mar 2022 07:20:53 GMT

we have a localized xml standard for road models that is based on LandXML. That means the LandXML exported from ORD isn't applicable to our clients standards and we need to make our own work-intensive adjustments after exporting the terrain model.

I haven't found a way in OpenRoads Designer to export terrain models in xml with schema other than LandXML only by making changes to some setting in the software. Is the only way to try to create something with the SDK or could there be more of a lighter way to do this (maybe without the SDK)?

linking in permits and other construction documents?

Dustin Powell — Tue, 26 Apr 2022 19:41:33 GMT

Hi,

we are currently in the process of migrating our plans to digital submission. mainly I work in OpenRoads but we have permit applications such as for environmental impacts and i was wondering if theres a way to link these to the model. yes i know we can use the insert object to create a clickable linked image but im wondering if theres something like a documents folder that can "hold" all the required permits?

Let me Help You

Mon, 01 Nov 2021 07:53:59 GMT

Answer a question that is verified as helpful or correct.

Ask A Question I

Fri, 29 Oct 2021 01:16:52 GMT

Ask a question in a forum.

Dustin Powell's Communities Activities