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.918Power InRoads 08.11.09.918OpenRoads 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.
Answer Verified By: 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 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