Is there a way to import a list of Key Stations into a Corridor? I am using SS10.
Hi Norman,
I created a VBA macro to add Key Stations to a corridor via a list in a text file. Happy to share if you know your way around VBA?
Regards,
Mark
OpenRoads Designer 2023 | Microstation 2023.2 | ProjectWise 2023
Hi Mark
Do you mind sharing that VBA macro with me?
Thanks
Hi Kenneth,
I've just posted it here in case anyone else needs it. Just rename BulkKeyStnImport.txt to .bas and the clsSelect.txt to .cls and import them into a mvba project.
How it works:
Note: This was developed for ORD and should work fine in the OR v8i versions as long as you remove the "PtrSafe" from the Declarations at the top of the Module
' vba Macro to bulk add Key Stations to Multiple Corridors in current DGN - by M. Shamoun (3/08/19) Declare PtrSafe Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long) Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (ByRef lpofn As OPENFILENAME) As Long Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long ' --------------------------------------------------------------------- ' Win32 API structure definition as user-defined type ' --------------------------------------------------------------------- Private Type OPENFILENAME lStructSize As Long hwndOwner As LongPtr hInstance As LongPtr lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As LongPtr lpTemplateName As String End Type ' --------------------------------------------------------------------- ' Win32 API constants ' --------------------------------------------------------------------- Private Const BIF_NEWDIALOGSTYLE As Long = &H40 Private Const BIF_RETURNONLYFSDIRS As Long = 1 Private Const MAX_PATH As Long = 260 Private Const OFN_OVERWRITEPROMPT As Long = &H2 Private Const OFN_FILEMUSTEXIST As Long = &H1000 Private Const OFN_PATHMUSTEXIST As Long = &H800 Private Const OFN_HIDEREADONLY As Long = &H4 '-------------------------------------------------------------- Sub main() Dim oScanEnumerator As ElementEnumerator, oScanEnumerator1 As ElementEnumerator Dim oElement As Element, oPoint As Point3d, oView As View, oElement2 As Element Dim ph As PropertyHandler, ph1 As PropertyHandler, oKeyStns() As String, Point As Point3d Dim oAlignment As Element, oAttachment As Attachment, oAttachments As Attachments Dim oReadDbl As Double Set oAttachments = ActiveModelReference.Attachments ' Check if current file is read only If ActiveModelReference.IsReadOnly = True Then CadInputQueue.SendCommand "beep" ShowMessage "ERROR - Current file is Read-Only", , msdMessageCenterPriorityError, True CommandState.StartDefaultCommand Exit Sub ' Check if current model is 3D ElseIf ActiveModelReference.Is3D = True Then CadInputQueue.SendCommand "beep" ShowMessage "ERROR - Current model is 3D (Corridors reside in 2D model)", , msdMessageCenterPriorityError, True CommandState.StartDefaultCommand Exit Sub End If ' Get current view For i = 1 To 8 If ActiveDesignFile.Views(i).IsSelected = True Then Set oView = ActiveDesignFile.Views(i) Exit For End If Next ' read variables to get SendKeys paths If ActiveWorkspace.IsConfigurationVariableDefined("CIVIL_LAYERED_STANDARDS_MACRO") = True Then cfgVarValue = ActiveWorkspace.ConfigurationVariableValue("CIVIL_LAYERED_STANDARDS_MACRO") ElseIf ActiveWorkspace.IsConfigurationVariableDefined("_USTN_WORKSPACESTANDARDS_MACRO") = True Then cfgVarValue = ActiveWorkspace.ConfigurationVariableValue("_USTN_WORKSPACESTANDARDS_MACRO") ElseIf ActiveWorkspace.IsConfigurationVariableDefined("_USTN_WORKSPACESTANDARDS_MACRO") = True Then cfgVarValue = ActiveWorkspace.ConfigurationVariableValue("SENDKEYS_PATH") Else ShowMessage "WARNING - SendKeys path location not found - Sync will wait to for user input", , msdMessageCenterPriorityWarning End If ' Get key program for dialog response Filename = "SendKeys.exe" skeys = cfgVarValue + Filename ' Send Key arguments for Templates edited in place (currently set to "Y" - change to "N" to force no update) sargs = " 1 5 " + Chr(34) + "Error" + Chr(34) + " " + Chr(34) + " " + Chr(34) + " 1" ' Start dialog to select text file for key stations restart: Dim oFile As String oDir = ActiveDesignFile.Path oFile = ShowOpen("Select Text File to Load Corridor Key Stations from", "", "Text files (*.txt)", "*.txt", oDir) If Len(oFile) = 0 Then CadInputQueue.SendCommand "beep" result = MsgBox("ERROR - No Corridor Key Station Text file selected", vbRetryCancel, "File Open Error") If result = vbRetry Then GoTo restart Else CadInputQueue.SendCommand "beep" ShowMessage "Macro Aborted", , msdMessageCenterPriorityError CommandState.StartDefaultCommand Exit Sub End If Else Open oFile For Input As #1 Do Until EOF(1) LineCount = LineCount + 1 ReDim Preserve oKeyStns(LineCount) Line Input #1, oKeyStns(LineCount) Loop Close #1 End If ' Select Alignment graphically Do CommandState.StartLocate New clsSelect ShowStatus " RESET TO ABORT" Set inp = CadInputQueue.GetInput(msdCadInputTypeAny) If inp.InputType = msdCadInputTypeDataPoint Then Set oAlignment = CommandState.LocateElement(Point, oView, True) If oAlignment Is Nothing Then 'loop ElseIf oAlignment.IsComplexStringElement = False Then CadInputQueue.SendCommand "beep" 'loop ElseIf oAlignment.IsComplexStringElement = True And oAlignment.IsTraversableElement = False Then CadInputQueue.SendCommand "beep" 'loop Else Exit Do End If ElseIf inp.InputType = msdCadInputTypeReset Then CadInputQueue.SendCommand "beep" ShowMessage "Macro Aborted", , msdMessageCenterPriorityError CommandState.StartDefaultCommand Exit Sub End If Loop ' Get Alignment length for scan and name Set ph0 = CreatePropertyHandler(oAlignment) If ph0.SelectByAccessString("LinearElement_Length") = True Then strval0 = ph0.GetValue length = Round(strval0, 3) End If Set ph1 = CreatePropertyHandler(oAlignment) If ph1.SelectByAccessString("FeatureName") = True Then oAlignName = ph1.GetDisplayString End If ' Get Stationing in current alignment chain = 0 countst = 0 ShowTempMessage msdStatusBarAreaMiddle, "Scanning model for Alignment Stationing reference..." Dim oScanCriteria As New ElementScanCriteria oScanCriteria.ExcludeGraphical ' Scan for stationing in reference file If oAlignment.ModelReference.IsAttachment = True Then oRef = oAlignment.ModelReference.DesignFile.FullName count = 1 For Each oAttachment In oAttachments oAttachmentname = oAttachment.DesignFile.FullName If oAttachmentname = oRef Then Set oScanEnumerator1 = ActiveModelReference.Attachments(count).Scan(oScanCriteria) oScanEnumerator1.Reset Do While oScanEnumerator1.MoveNext countrun = 1 Set oElement1 = oScanEnumerator1.Current If oElement1.IsCellElement = False And oElement1.ModelReference.IsAttachment = True Then Set ph2 = CreatePropertyHandler(oElement1) If ph2.SelectByAccessString("AssignedStation") = True Then val2 = Replace(ph2.GetDisplayString, "+", "") stn1 = Round(val2, 3) End If Set ph3 = CreatePropertyHandler(oElement1) If ph3.SelectByAccessString("BeginStation") = True Then valb = Replace(ph3.GetDisplayString, "+", "") stnb = Round(valb, 3) End If Set ph4 = CreatePropertyHandler(oElement1) If ph4.SelectByAccessString("EndStation") = True Then vale = Replace(ph4.GetDisplayString, "+", "") stne = Round(vale, 3) End If Length1 = Round((stne - stnb), 3) If Length1 > 0 And Round(Length1, 3) = Round(length, 3) Then chain = stnb ShowTempMessage msdStatusBarAreaMiddle, "Scanning Reference for Alignment Stationing reference...FOUND" countst = 1 GoTo cont End If End If countrun = countrun + 1 If countrun = 100 Then ShowMessage "MACRO ABORTED - Search Timeout", , msdMessageCenterPriorityError CadInputQueue.SendCommand "beep" CommandState.StartDefaultCommand Exit Sub End If Loop End If count = count + 1 Next ' Scan for stationing in current file ElseIf oAlignment.ModelReference.IsAttachment = False Then Set oScanEnumerator1 = ActiveModelReference.Scan(oScanCriteria) oScanEnumerator1.Reset Do While oScanEnumerator1.MoveNext Set oElement1 = oScanEnumerator1.Current If oElement1.IsCellElement = False And oElement1.ModelReference.IsAttachment = False Then Set ph2 = CreatePropertyHandler(oElement1) If ph2.SelectByAccessString("AssignedStation") = True Then val2 = Replace(ph2.GetDisplayString, "+", "") stn1 = Round(val2, 3) End If Set ph3 = CreatePropertyHandler(oElement1) If ph3.SelectByAccessString("BeginStation") = True Then valb = Replace(ph3.GetDisplayString, "+", "") stnb = Round(valb, 3) End If Set ph4 = CreatePropertyHandler(oElement1) If ph4.SelectByAccessString("EndStation") = True Then vale = Replace(ph4.GetDisplayString, "+", "") stne = Round(vale, 3) End If Length1 = Round((stne - stnb), 3) If Length1 > 0 And Round(Length1, 3) = Round(length, 3) Then chain = stnb ShowTempMessage msdStatusBarAreaMiddle, "Scanning Model for Alignment Stationing reference...FOUND" countst = 1 Exit Do End If End If Loop End If If countst = 0 Then ShowMessage "WARNING - No Stationing found for selected Alignment", , msdMessageCenterPriorityError End If cont: ' Scan for Corridors in current model Dim oScanCriteria1 As New ElementScanCriteria oScanCriteria1.ExcludeNonGraphical oScanCriteria1.ExcludeAllClasses oScanCriteria1.IncludeClass (msdElementClassConstruction) ' Scan for total Corridors in current model using selected Alignment Set oScanEnumerator1 = ActiveModelReference.Scan(oScanCriteria1) count1 = 0 Do While oScanEnumerator1.MoveNext Set oElement2 = oScanEnumerator1.Current Set ph2 = CreatePropertyHandler(oElement2) If ph2.SelectByAccessString("ElementDescription") = True Then strval2 = ph2.GetValue If Left(strval2, 8) = "Corridor" Then Set ph3 = CreatePropertyHandler(oElement2) ' Check corridor alignment name If ph3.SelectByAccessString("HorizontalName") = True Then strval3 = ph3.GetValue If strval3 = oAlignName Then count1 = count1 + 1 End If End If End If End If Loop If count1 = 0 Then GoTo skip Else ShowTempMessage msdStatusBarAreaMiddle, Str(count1) + " " + oAlignName + " Corridors found - Adding Key Stations..." End If ' Turn on all constructions oView.DisplaysConstructions = True oView.Redraw ' Pre-scan model Set oScanEnumerator = ActiveModelReference.Scan(oScanCriteria1) Do While oScanEnumerator.MoveNext Loop ' Add Key Stations to all matching Alignment Corridor count = 0 oScanEnumerator.Reset Do While oScanEnumerator.MoveNext And count < count1 Set oElement = oScanEnumerator.Current Set ph4 = CreatePropertyHandler(oElement) If ph4.SelectByAccessString("ElementDescription") = True Then strval4 = ph4.GetValue If Left(strval4, 8) = "Corridor" Then ' Isolate Corridor boundary to avoid selection of alternate corridors using same co-ordinates ' Clear all previous selections ActiveModelReference.UnselectAllElements CadInputQueue.SendCommand "displayset clear" ActiveModelReference.SelectElement oElement CadInputQueue.SendCommand "displayset set selection" Set ph5 = CreatePropertyHandler(oElement) If ph5.SelectByAccessString("FeatureName") = True Then strval5 = ph5.GetValue End If ShowTempMessage msdStatusBarAreaMiddle, Str(count1) + " Corridors found - Adding Key Stations to " + strval5 count = count + 1 oVertexList = oElement.ConstructVertexList(0) total = UBound(oVertexList) oPoint.X = oVertexList(1).X oPoint.Y = oVertexList(1).Y oPoint.Z = 0 ' Clear all previous selections ActiveModelReference.UnselectAllElements counter = 0 Countvalid = 0 Do counter = counter + 1 oRead = Trim(oKeyStns(counter)) ' Check if text line is all digits If IsNumeric(oRead) Then ' Remove start station to use adjusted values in leyin oReadAdj = Trim(oKeyStns(counter)) - chain oReadDbl = oRead ' Check if stations are before or after alignment range If (oReadDbl > stne) Or (oReadDbl < stnb) Then ShowMessage "Station on Text file Line" + Str(counter) + " is outside Alignment range", , msdMessageCenterPriorityWarning Else ' Start Corridor Key Station Command CadInputQueue.SendKeyin "CORRIDOR KEYSTATION CREATE " ' Select point on corridor boundary to select corridor CadInputQueue.SendDataPoint oPoint, oView ' Else add key stations If FileExists(skeys) Then ' Run SendKeys program to send keypress to answer dialogs (for edited in place templates, not found, etc) Call Shell(Chr(34) + skeys + Chr(34) + sargs, vbNormalFocus) End If CadInputQueue.SendKeyin "CIVILCMD LOCKVALUE Station" CadInputQueue.SendKeyin "CIVILCMD SETVALUE Station=<Station>" + CStr(oReadAdj) + ",False,4</Station>" Sleep 500 CadInputQueue.SendDataPoint oPoint, oView Countvalid = Countvalid + 1 If FileExists(skeys) Then ' Run SendKeys program to send keypress to answer dialogs (for edited in place templates, not found, etc) Call Shell(Chr(34) + skeys + Chr(34) + sargs, vbNormalFocus) End If End If Else ShowMessage "Non-numeric data found on Text file Line" + Str(counter), , msdMessageCenterPriorityWarning End If Loop Until counter = LineCount End If End If Loop CadInputQueue.SendCommand "displayset clear" CadInputQueue.SendReset skip: ' report status of process If count1 = 0 Then CadInputQueue.SendCommand "beep" ShowMessage "ERROR - No " + oAlignName + " Corridors found in current model", , msdMessageCenterPriorityError, True Else CadInputQueue.SendCommand "beep" ShowMessage CStr(Countvalid) + " Key Stations added to" + Str(count) + " x Corridors using " + oAlignName, , msdMessageCenterPriorityInfo, True End If CommandState.StartDefaultCommand End Sub ' --------------------------------------------------------------------- ' ShowSave Save As... common dialog ' Arguments: [in, String] dialog title, ' [in, String] filter description, [optional] ' [in, String] filter spec, [optional] ' [in, String] default directory [optional] ' Example call: ' dgnFile = ShowSave ("Save Design File As...", "MicroStation Files (*.dgn)", "*.dgn", "V:\shared") ' Returns: full path of file to be saved ' --------------------------------------------------------------------- Function ShowSave( _ ByVal strDialogTitle As String, _ ByVal strProposed As String, _ Optional ByVal strFilterDescr As String = "All files (*.*)", _ Optional ByVal strFilterSpec As String = "*.*", _ Optional ByVal strDefaultDir As String = vbNullString) As String On Error Resume Next Dim strFilter As String, _ strFileSelected As String, _ proposed As String Dim OFName As OPENFILENAME strFilter = strFilterDescr + Chr$(0) + strFilterSpec + Chr$(0) proposed = strProposed & Chr$(0) & Space$(254 - Len(strProposed)) 'Create a buffer Const Period As String = "." With OFName .lStructSize = LenB(OFName) ' Set the structure size. Note use of LenB() not Len() .hwndOwner = 0& ' Set the owner window .hInstance = 0& ' Set the application's instance .lpstrFilter = strFilter 'Set the filter .lpstrFile = proposed .lpstrDefExt = Mid$(strFilterSpec, 1 + InStr(strFilterSpec, Period)) .nMaxFile = 255 ' Set the maximum number of chars .lpstrFileTitle = Space$(254) ' Create a buffer .nMaxFileTitle = 255 'Set the maximum number of chars If (vbNullString <> strDefaultDir) Then _ .lpstrInitialDir = strDefaultDir 'Set the initial directory .lpstrTitle = strDialogTitle 'Set the dialog title .flags = OFN_OVERWRITEPROMPT 'no extra flags End With If GetSaveFileName(OFName) Then 'Show the 'Save File' dialog strFileSelected = Trim$(OFName.lpstrFile) If (InStr(strFileSelected, Chr(0)) > 0) Then strFileSelected = Left(strFileSelected, InStr(strFileSelected, Chr(0)) - 1) End If ShowSave = Trim(strFileSelected) Else ShowSave = "" End If End Function ' --------------------------------------------------------------------- ' ShowOpen Open common dialog ' Arguments: [in, String] dialog title, ' [in, String] proposed name, [optional] ' [in, String] filter description, [optional] ' [in, String] filter spec, [optional] ' [in, String] default directory [optional] ' Example call: ' dgnFile = ShowOpen ("Open Design File", "MicroStation Files (*.dgn)", "*.dgn", "V:\shared") ' Returns: full path of file to be opened ' --------------------------------------------------------------------- Function ShowOpen(ByVal title As String, _ ByVal proposedName As String, _ ByVal filterDescription As String, _ ByVal filter As String, _ ByVal initialDirectory As String) As String ShowOpen = vbNullString On Error Resume Next Dim strFilter As String, _ strFileSelected As String, _ proposed As String Dim OFName As OPENFILENAME strFilter = filterDescription + Chr$(0) + filter + Chr$(0) proposed = proposedName & Chr$(0) & Space$(254 - Len(proposed)) 'Create a buffer Const Period As String = "." With OFName .lStructSize = LenB(OFName) ' Set the structure size. Note use of LenB() not Len() .hwndOwner = 0& ' Set the owner window .hInstance = 0& ' Set the application's instance .lpstrFilter = strFilter 'Set the filter .lpstrFile = proposed .lpstrDefExt = Mid$(filter, 1 + InStr(filter, Period)) .nMaxFile = 255 ' Set the maximum number of chars .lpstrFileTitle = Space$(254) ' Create a buffer .nMaxFileTitle = 255 'Set the maximum number of chars If (vbNullString <> initialDirectory) Then _ .lpstrInitialDir = initialDirectory 'Set the initial directory .lpstrTitle = title 'Set the dialog title .flags = OFN_FILEMUSTEXIST 'no extra flags End With If GetOpenFileName(OFName) Then 'Show the 'Open File' dialog strFileSelected = Trim$(OFName.lpstrFile) If (InStr(strFileSelected, Chr(0)) > 0) Then strFileSelected = Left(strFileSelected, InStr(strFileSelected, Chr(0)) - 1) End If ShowOpen = Trim(strFileSelected) Else ShowOpen = vbNullString End If End Function Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean 'Purpose: Return True if the file exists, even if it is hidden. 'Arguments: strFile: File name to look for. Current directory searched if no path included. ' bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True. 'Note: Does not look inside subdirectories for the file. 'Author: Allen Browne. http://allenbrowne.com June, 2006. Dim lngAttributes As Long 'Include read-only files, hidden files, system files. lngAttributes = (vbReadOnly Or vbHidden Or vbSystem) If bFindFolders Then lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well. Else 'Strip any trailing slash, so Dir does not look inside the folder. Do While Right$(strFile, 1) = "\" strFile = Left$(strFile, Len(strFile) - 1) Loop End If 'If Dir() returns something, the file exists. On Error Resume Next FileExists = (Len(Dir(strFile, lngAttributes)) > 0) End Function Function FolderExists(strPath As String) As Boolean On Error Resume Next FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory) End Function Function TrailingSlash(varIn As Variant) As String If Len(varIn) > 0 Then If Right(varIn, 1) = "\" Then TrailingSlash = varIn Else TrailingSlash = varIn & "\" End If End If End Function
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "clsSelect" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Implements ILocateCommandEvents Public Sub ILocateCommandEvents_Accept(ByVal oElement1 As Element, Point As Point3d, ByVal oView As View) If oElement1 Is Nothing Then CommandState.StartLocate New clsSelect ElseIf oElement1.IsComplexStringElement = False Then CadInputQueue.SendCommand "beep" MsgBox "ERROR - Invalid complex element selected - Try again" CommandState.StartLocate New clsSelect End If End Sub Private Sub ILocateCommandEvents_Cleanup() End Sub Private Sub ILocateCommandEvents_Dynamics(Point As Point3d, ByVal oView As View, ByVal DrawMode As MsdDrawingMode) End Sub Private Sub ILocateCommandEvents_LocateFailed() ShowStatus "Invalid Element Selection - Try Again" CommandState.StartLocate New clsSelect End Sub Private Sub ILocateCommandEvents_LocateFilter(ByVal oElement1 As Element, Point As Point3d, Accepted As Boolean) If oElement1.IsComplexStringElement = True And oElement1.IsTraversableElement = True Then Accepted = True oElement1.IsHighlighted = True Else Accepted = False End If End Sub Private Sub ILocateCommandEvents_LocateReset() CadInputQueue.SendCommand "beep" ShowMessage "" CommandState.StartDefaultCommand Exit Sub End Sub Private Sub ILocateCommandEvents_Start() Dim lc As LocateCriteria ' Since this command does not modify the original element, ' set the locate criteria to allow read-only elements. Set lc = CommandState.CreateLocateCriteria(False) lc.ExcludeAllTypes lc.IncludeType msdElementTypeArc lc.IncludeType msdElementTypeLine lc.IncludeType msdElementTypeComplexString lc.IncludeOnlySnappable CommandState.SetLocateCriteria lc ' MicroStation disables AccuSnap whenever a new command starts, so a command ' should enable AccuSnap whenever it is appropriate. This user still has the ' ability to turn off AccuSnap. Enabling AccuSnap does not override that. ' EnableAccuSnap only enables AccuSnap if the user has it turned on. CommandState.EnableAccuSnap ShowPrompt "Select Reference Alignment (RESET TO ABORT - TAB TO CYCLE)" End Sub
As I try to run on this on ORD I get an error on line 174 of the BulkKeyStnImport module after selecting my text file and alignment - "run-time error '13': type mismatch", what does the text file need to look like? It seems there's something I'm missing.
I also get this error. Have you figured something?
I should have put an example. It simply reads the key station from each line of a text file. The issue may be that we use metric 0.000 formatted stations here. What format of stations is giving you this issue?
Thank you for your fast reply. I am also using metric stations. I tried with an example as shown in the Corridor Objects under key stations as 11+252,075 for example. Now I also tried with something like 11252.075 but still didn't work.
Do I need a specific format for the station and does it also depend on my design file setting when it comes to decimals and formatting? Also do I need to leave any empty spaces (like a TAB) before the station?
Thank you
hmm, it works as it should on my end. I'll check the code I posted earlier to see iif theres anything missing.