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

.

Parents
  • 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.

    Answer Verified By: Dustin Powell 

Reply
  • 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.

    Answer Verified By: Dustin Powell 

Children