VBA to interface with civil reports?

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

.

  • There is a forum specifically for Civil programming. you may find assistance or ideas over there.

    You can Move your post using the "More" option beneath it.

    MaryB

    Power GeoPak 08.11.09.918
    Power InRoads 08.11.09.918
    OpenRoads Designer 2021 R2

        

  • Option Explicit
    
    Sub GetArrayData()
    'requires microsoft excel 16.0 object library reference
           Dim MyArray() As Variant
        Dim Data As Variant
        Dim myPath, myFile, DGNFile, NewestFile, PointText, Trackr, Tailend As String
        Dim c As Long, N, erCatch As Integer
        Dim LatestDate As Date
        Dim LMD As Date
        
      DGNFile = "*" & ActiveDesignFile.Path & "*"
    
        myPath = Environ$("TEMP") 'file path of xml report
        'debug.print myPath
        If Right(myPath, 1) <> "\" Then myPath = myPath & "\"
        myFile = Dir(myPath & "*.xml", vbNormal)
        If Len(myFile) = 0 Then
            MsgBox "No files were found...", vbExclamation
            Exit Sub
        End If
        Do While Len(myFile) > 0
            LMD = FileDateTime(myPath & myFile)
            'check file for tag
            Open myPath & myFile For Input As #1 'Len = Len(myRecord)
        For N = 1 To 3
       
           Line Input #1, Data
            
                Select Case True
                'is file a station offset report?
                Case Data Like "*Station Offset Report*" 'check lines 1-3 for command name
                '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
                NewestFile = myFile
                LatestDate = LMD
                End If
                End If
                End Select
        Next
       Close #1
            myFile = Dir
        Loop
        
         If Len(NewestFile) = 0 Then
            MsgBox "No files were found Please Run Station Offset Report", vbExclamation
            Exit Sub
        End If
    
    
        Open myPath & NewestFile For Input As #1
        
        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)
                    'Debug.Print PointText
                    MyArray(1, c) = PointText
                    'reset or continue counting
                    Trackr = ""
                    c = c + 1
               
            End Select
        Loop
        
        Close #1
        If erCatch = 0 Then
        MsgBox "No data Found"
        Exit Sub
        End If
        'remove this area and restructure for input to microstation
        ''SaveArrayToTextFile myPath, MyArray'uncomment to save text file
        Microstation Code (MyArray)
        'MyArray = Application.WorksheetFunction.Transpose(MyArray)
            'Range("A1").Resize(UBound(MyArray, 1), UBound(MyArray, 2)) = MyArray 'excel output
    End Sub
    
    Sub SaveArrayToTextFile(myPath2 As String, MyArray2 As Variant)
    
        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

    OK so i went an alternate route given that i couldn't capture the file name i settled for finding the latest file in the folder and filtering by type. included is a data extraction code which passes line text to an array when it meets certain criteria in the loop text search. i'd apologize for the need to use excel library but i couldnt find an alternative for substituting the unwanted text. 

    Added in another loop at the start to check that we are in the same project folder and that the command for the xml report is the correct one.

    MISSING RESOURCE: VerifiedBy Dustin Powell 

  • I've looked for a similar workflow and thank you for offering your solution. It has inspired me to do some interfacing with XML as well. (After looking at your code, I was confused by many things, so I decided to change a few key variable names, and doing even so little makes it a lot more legible.)

    I wonder, before you came to this solution or since then, have you looked at using the Microsoft XML object library? I feel like that might be a lot smoother and more scalable. I'll be checking it out myself when I have the time.

  • I'd be interested to know what variables were renamed Slight smile its sometimes hard to see a different perspective when coding but i like to be flexible. On the microsoft xml object library i did consider it but i was attempting to avoid using object libraries that aren't the default because i dont like hard coding a library to load as it may be outdated eventually. but if you do manage to get the XML code working i'd love to see it.

  • This code does work.

    Sub GetArrayData() 'processes information from report XML
    	'requires microsoft excel 16.0 object library reference
    	Dim SetOfRecords() As Variant 'might be better as a collection
    	Dim Record As Variant
        Dim LineOfXmlFile As Variant
        Dim PathToXmlFolder, NamesOfXmlFiles, PathToDgnFile, NameOfLatestXmlWithCommand, XmlCodeOfInterest, RemainderOfXmlLine As String
        Dim ProcessPointBecauseInOLP As Boolean
        Dim iRecord As Long, iLineOfXml, identifierFailureMode As Integer
        Dim DateOfLatestXmlFile As Date
        Dim DateOfThisXmlFile As Date
        
    	'TODO: Chunk out these processes, for pete's sake!
    	
    	'PathToLatestXmlFile = GetLatestXmlFile(Environ$("TEMP"), "*Station Offset Report*") 'both arguments should be optional
    	'Set Records = MineXmlFileForOffsetLinePoint(PathToLatestXmlFile) 'maybe there could be a way to generalize this for which attributes (and whose) to collect
    	'Tabulate Records
    	
    	PathToDgnFile = "*" & ActiveDesignFile.Path & "*"
    	
        PathToXmlFolder = Environ$("TEMP") 'file path of xml report
        If Right(PathToXmlFolder, 1) <> "\" Then PathToXmlFolder = PathToXmlFolder & "\"
        Debug.Print PathToXmlFolder
        
        NamesOfXmlFiles = Dir(PathToXmlFolder & "*.xml", vbNormal)
        Debug.Print NamesOfXmlFiles
        
        If Len(NamesOfXmlFiles) = 0 Then
            MsgBox "No XML was found.", vbExclamation
            Exit Sub
        End If
        
        Do While Len(NamesOfXmlFiles) > 0
            DateOfThisXmlFile = FileDateTime(PathToXmlFolder & NamesOfXmlFiles)
            Debug.Print DateOfThisXmlFile
            'check file for tag
            Open PathToXmlFolder & NamesOfXmlFiles For Input As #1
            
            For iLineOfXml = 1 To 3
                'Debug.Print iLineOfXml
                Line Input #1, LineOfXmlFile
                Debug.Print iLineOfXml & vbTab & LineOfXmlFile
                If LineOfXmlFile Like "*Station Offset Report*" Then
                    'go to next line of file then
                    'Line Input #1, LineOfXmlFile
                    'debug.print LineOfXmlFile
                    'does file tag match PathToDgnFile path
                    If DateOfThisXmlFile > DateOfLatestXmlFile Then
                        NameOfLatestXmlWithCommand = NamesOfXmlFiles
                        DateOfLatestXmlFile = DateOfThisXmlFile
                    End If
                End If
            Next
       Close #1
            NamesOfXmlFiles = Dir
        Loop
        
         If Len(NameOfLatestXmlWithCommand) = 0 Then
            Debug.Print "No files were found Please Run Station Offset Report", vbExclamation
            Exit Sub
        End If
    
    
        Open PathToXmlFolder & NameOfLatestXmlWithCommand For Input As #1
        
        identifierFailureMode = 0
        iRecord = 1
        Do Until EOF(1)
            Line Input #1, LineOfXmlFile
            Select Case True
                'use ProcessPointBecauseInOLP to find values to pass to array
                Case LineOfXmlFile Like "*<offsetLinePoint*" 'change this to the line just before your desired capture
                    ProcessPointBecauseInOLP = True 'value to make sure we are only getting the areas we want in each loop
                    identifierFailureMode = 1 'value to see if LineOfXmlFile exists
                
                Case LineOfXmlFile Like "*<point*" And ProcessPointBecauseInOLP
                                    'remove and replace text ; delineated
                    XmlCodeOfInterest = Excel.WorksheetFunction.Substitute(LineOfXmlFile, "<point", "")
                    XmlCodeOfInterest = Excel.WorksheetFunction.Substitute(XmlCodeOfInterest, ">", "")
                    XmlCodeOfInterest = Excel.WorksheetFunction.Substitute(XmlCodeOfInterest, "northing=", ";") 'ycoordinate
                    XmlCodeOfInterest = Excel.WorksheetFunction.Substitute(XmlCodeOfInterest, "easting=", ";") 'xcoordinate
                    XmlCodeOfInterest = Excel.WorksheetFunction.Substitute(XmlCodeOfInterest, "elevation=", ";") 'zcoordinate
                    'locate and replace pointless text at end of string
                    RemainderOfXmlLine = Mid(XmlCodeOfInterest, InStr(1, XmlCodeOfInterest, "pointType"), Len(XmlCodeOfInterest) + 1 - InStr(1, XmlCodeOfInterest, "pointType"))
                    XmlCodeOfInterest = Excel.WorksheetFunction.Substitute(XmlCodeOfInterest, RemainderOfXmlLine, "")
                    'Debug.Print XmlCodeOfInterest
                    XmlCodeOfInterest = Excel.WorksheetFunction.Substitute(XmlCodeOfInterest, Chr(34), "") 'remove quotes
                    XmlCodeOfInterest = Trim(XmlCodeOfInterest)
                    If IsNumeric(XmlCodeOfInterest) Then XmlCodeOfInterest = Val(XmlCodeOfInterest)
                    
    				Debug.Print iRecord & vbTab & XmlCodeOfInterest
                    Cells(iRecord, 1) = XmlCodeOfInterest
    				
    				ReDim Preserve SetOfRecords(1, 1 To iRecord)
    				SetOfRecords(1, iRecord) = XmlCodeOfInterest
                    'reset or continue counting
                    ProcessPointBecauseInOLP = False
                    If Not XmlCodeOfInterest = "" Then iRecord = iRecord + 1
               
            End Select
        Loop
        
    	'iRecord = 1
    	'For Each Record In SetOfRecords
    	'	Debug.Print iRecord & vbtab & Record
    	'	iRecord = iRecord + 1
    	'Next Record
    	
        Close #1
        If identifierFailureMode = 0 Then
        MsgBox "No data Found"
        Exit Sub
        End If
        'remove this area and restructure for input to microstation
        ''SaveArrayToTextFile PathToXmlFolder, SetOfRecords'uncomment to save text file
        'Microstation Code(SetOfRecords)
        'SetOfRecords = Application.WorksheetFunction.Transpose(SetOfRecords)
            'Range("A1").Resize(UBound(SetOfRecords, 1), UBound(SetOfRecords, 2)) = SetOfRecords 'excel output
    End Sub

    Also, this below code is kind of a quick, sloppy demo of using MSXML2, mainly as a proof of the basics.

    Sub research_Xml()
        Dim objXml As New MSXML2.DOMDocument60
        Dim path As String
        Dim XmlFileIsLoaded As Boolean
        Dim XPathString As String
        
        XPathString = "(/*/*//*)[position() < 5]"
        
        Dim stuffs As MSXML2.IXMLDOMNodeList
        Dim node As MSXML2.IXMLDOMNode
        Dim attr As MSXML2.IXMLDOMAttribute
        
        Dim x As Variant
        
        path = Environ$("TEMP") & "\" & GetLatestXmlFile
        Debug.Print path
        
        If path = "" Then
            MsgBox "No XML file found with filter given."
            Exit Sub
        End If
        
        With objXml
            .async = False
            XmlFileIsLoaded = .Load(path)
            Debug.Print XmlFileIsLoaded
        End With
        
        If XmlFileIsLoaded Then
            '.SetProperty "SelectionLanguage", "XPath" ' this appears to be nonessential
            'for issues with this or for ideas of what you can do, though, do a search for XPath
            
            Debug.Print "------------------"
            Debug.Print objXml.ChildNodes(0).BaseName 'xml
            Debug.Print objXml.ChildNodes(1).BaseName 'InRoads
            
            Set stuffs = objXml.SelectNodes(XPathString)
            Debug.Print stuffs.Length
            
            For Each node In stuffs
                Debug.Print node.BaseName
                Debug.Print node.XML ' prints the plain XML for the selected node, including child nodes and attributes
                
                For Each attr In node.Attributes
                    Debug.Print vbTab & attr.BaseName & " = " & attr.Text ' does as you can expect: x = -24.00000000
                Next attr
            Next node
        End If
    End Sub
    
    
    
    Private Function GetLatestXmlFile(Optional PathToXmlFolder As String, Optional Command As String = "*commandName=""*", Optional Baseline As String) As String
        If PathToXmlFolder = "" Then PathToXmlFolder = Environ$("TEMP")
        
        'requires MSXML2
        
        'HorzXml = GetLatestXmlFile(, "*Horizontal Geometry Report*")
        'SuperXml = GetLatestXmlFile(, "*Superelevation Report*")
        'so we can process geometry and super together to highlight where we expect to see problems in cross slope or longitudinal slope
        'make sure to check for a common baseline alignment (Baseline is listed in the arguments but isn't currently used)
        'make sure to overcome the units mismatch in internalStation
        
        'using the MSXML OBL should go a long way to imagining new ways to identify and process report xml
        
        Dim NameOfThisXmlFile, NameOfLatestXmlWithCommand As String
        Dim XmlFileNumber As Integer
        Dim DateOfLatestXmlFile As Date
        Dim DateOfThisXmlFile As Date
        
        If Right(PathToXmlFolder, 1) <> "\" Then PathToXmlFolder = PathToXmlFolder & "\"
        Debug.Print PathToXmlFolder
        
        NameOfThisXmlFile = Dir(PathToXmlFolder & "*.xml", vbNormal) ' look into what this returns. what if it returns more than one file name?
        Debug.Print NameOfThisXmlFile, TypeName(NameOfThisXmlFile)
        
        If Len(NameOfThisXmlFile) = 0 Then
            MsgBox "No XML file was found.", vbExclamation
            Exit Function
        End If
        
        Debug.Print NameOfThisXmlFile
        
        Do While NameOfThisXmlFile <> ""
            DateOfThisXmlFile = FileDateTime(PathToXmlFolder & NameOfThisXmlFile)
            Debug.Print DateOfThisXmlFile
            
            XmlFileNumber = FreeFile
            
            Open PathToXmlFolder & NameOfThisXmlFile For Input As #XmlFileNumber ' Input is to read in order (not random access)
            
            For iLineOfXml = 1 To 3 'this might look like it can be trimmed to just the second line, but the cost is minuscule and anyway, some reports may not be generated this way
                'Debug.Print iLineOfXml
                Line Input #XmlFileNumber, LineOfXmlFile
                'Debug.Print iLineOfXml & vbTab & LineOfXmlFile
                'Debug.Print LineOfXmlFile Like Command, DateOfThisXmlFile > DateOfLatestXmlFile
                If LineOfXmlFile Like Command And DateOfThisXmlFile > DateOfLatestXmlFile Then
                    NameOfLatestXmlWithCommand = NameOfThisXmlFile
                    DateOfLatestXmlFile = DateOfThisXmlFile
                End If
            Next
            
            Close #XmlFileNumber
            
            NameOfThisXmlFile = Dir 'to cycle through the rest of the files captured by the first call to Dir
        Loop
        
        If Len(NameOfLatestXmlWithCommand) = 0 Then
            Debug.Print "No XML files were found with the command filter given."
            Exit Function
        End If
        
        GetLatestXmlFile = NameOfLatestXmlWithCommand 'which will be "" if there is no file
    End Function

    Anyway, I'm forever indebted to you because without this backbone and inspiration, I'm not sure I would have gotten as far as I have on this now.

    In case you already came across this and found that the latter two subs didn't work, it's because I failed to properly test. Since then I've made corrections and they should work together.

    And I acknowledge that it's a pain to attach object libraries every time. Well, have a look at this to do it programmatically with the GUIDs: https://stackoverflow.com/questions/9879825/how-to-add-a-reference-programmatically-using-vba

    This might help:

    Sub main()
    	Const strGuid_Excel$ = "{00020813-0000-0000-C000-000000000046}"
    	Const strGuid_MicrostationDGN$ = "{CF9F97BF-39F2-4B8E-835C-8BE9E99DAF5B}"
    	Const strGuid_MSXML2$ = "{F5078F18-C551-11D3-89B9-0000F81FE221}" 'Microsoft XML 6
    
        AddObjectLibraryReference_Guid strGuid_Excel$
        AddObjectLibraryReference_Guid strGuid_MicrostationDGN$, 8 '8.9 aka SS4, SS10
        'AddObjectLibraryReference_Guid strGuid_MicrostationDGN$, 10 '10 aka ORD
        AddObjectLibraryReference_Guid strGuid_MSXML2$, 6
        
        ListAddedObjectLibrariesGUID True
    End Sub
    
    Sub ListAddedObjectLibrariesGUID(Optional AfterAdding As Boolean = False, Optional ReportMore As Boolean = False)
    	If AfterAdding Then Debug.Print "------------- after adding references:"
        
        Dim ref
    	
    	For Each ref In ThisWorkbook.VBProject.References
    		With ref
    			Debug.Print .GUID, .Name & " v " & .Major & "." & .Minor
    			
    			If ReportMore Then 
    				'Debug.Print TypeName(ref)
    				
    				'these properties are also available:
    				'   .Type is attested only as 0
    				'   .BuiltIn
    				'   .Collection (which is the same type as ThisWorkBook.VBProject.References)
    				'   .Description
    				'   .IsBroken
    				'   .VBE
    				
    				'.VBE has these properties:
    				'   .ActiveCodePane
    				'   .ActiveVBProject
    				'   .ActiveWindow
    				'   .CodePanes
    				'   .CommandBars
    				'   .Events
    				'   .MainWindow
    				'   .SelectedVBComponent
    				'   .VBProjects
    				'   .Version
    				'   .Windows
    			End If
    		End With
        Next ref
    End Sub
    
    Function IsReferenceAdded_Guid(strGuid As String) As Boolean
    
        Dim varRef As Variant
    
        For Each varRef In ThisWorkbook.VBProject.References
            
            If varRef.GUID = strGuid Then
                IsReferenceAdded_Guid = True
                Exit For
            End If
            
        Next varRef
    
    End Function
    
    Sub AddObjectLibraryReference_Guid(strGuid As String, Optional MajorVersion = 0, Optional MinorVersion = 0)
        'when MajorVersion is 0, supposedly this selects the latest version, but that isn't observed
        
        If IsReferenceAdded_Guid(strGuid) = False Then
            ThisWorkbook.VBProject.References.AddFromGuid strGuid, MajorVersion, MinorVersion
        End If
    End Sub