Import Corridor Key Station

Is there a way to import a list of Key Stations into a Corridor? I am using SS10.

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

    • Create a text file with the key stations you want on each line
    • Start the Macro and it will prompt you to open the text file
    • Now select the Base Alignment for all Corridors that need these Key Stations added
    • It will then add these Key Stations to all Corridors that use that Alignment as their Baseline (I recommend unlocking the Corridors before starting the Macro as each Key Station add will initiate Corridor processing)
    • Any Key Stations that already exist will show a dialog and the macro will pause till the dialog is closed (I haven't had a chance to address this yet)

     

    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
    

    Regards,

    Mark


    OpenRoads Designer 2023  |  Microstation 2023.2  |  ProjectWise 2023

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

    • Create a text file with the key stations you want on each line
    • Start the Macro and it will prompt you to open the text file
    • Now select the Base Alignment for all Corridors that need these Key Stations added
    • It will then add these Key Stations to all Corridors that use that Alignment as their Baseline (I recommend unlocking the Corridors before starting the Macro as each Key Station add will initiate Corridor processing)
    • Any Key Stations that already exist will show a dialog and the macro will pause till the dialog is closed (I haven't had a chance to address this yet)

     

    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
    

    Regards,

    Mark


    OpenRoads Designer 2023  |  Microstation 2023.2  |  ProjectWise 2023

Children
  • 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?

    Regards,

    Mark


    OpenRoads Designer 2023  |  Microstation 2023.2  |  ProjectWise 2023

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

    Regards,

    Mark


    OpenRoads Designer 2023  |  Microstation 2023.2  |  ProjectWise 2023