MicroStation VBA读文本文件示例源代码

将以下代码创建为modTextReader

Option Explicit
Option Base 0
' ---------------------------------------------------------------------
Private Const sMODULE_NAME          As String = "TextFileReader"
Private Const nDateStamp            As Long = 20050301 ' Year/month/day
' ---------------------------------------------------------------------
'   Description:
'
'   Utility to read lines from a text file that contains X,Y,Z values.
'   The values are used to create an array of Point3d vertices.
'   Finally, the vertex list is used to create a line string.
'
' ---------------------------------------------------------------------
'   Example data.  Cut & paste this into coordinates.txt
'   ;  Comma-separated list of Point3D coordinates
'   ;  Sample data suppled by LA Solutions Ltd
'   ;  http://www.la-solutions.co.uk/
'   ; X, Y, Z
'   100, 100, 0
'   110, 100, 0
'   110, 110, 0
'   115, 115, 0
'   115, 120, 0
'   110, 120, 0
'   100, 120, 0
'   100, 100, 0
'   ; 8 coordinates supplied
'   Don't forget to remove the VB comment characters
' ---------------------------------------------------------------------
'   To run this utility keyin:
'   vba run [TextFileReader]modMain.Main
' ---------------------------------------------------------------------
'   Notice:
'
'   TextFileReader is provided by LA Solutions at no cost and
'   with no license requirement
'
'   This software is provided with no warranty and no declaration of
'   fitness for any purpose.  No support is provided.
'   You may use this software and copy it to others inside or outside
'   your organisation provided that this notice is retained in full.
'
'   Copyright ?2005 LA Solutions Ltd
' ---------------------------------------------------------------------
'   This module references the Windows Scripting Runtime library
' ---------------------------------------------------------------------
'   Win32 API declarations so that VBA can call
'   Windows functions directly
' ---------------------------------------------------------------------
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
' ---------------------------------------------------------------------
'   Win32 API structure definition as user-defined type
' ---------------------------------------------------------------------
Private Type OPENFILENAME
    lStructSize         As Long
    hWndOwner           As Long
    hInstance           As Long
    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 Long
    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_READONLY              As Long = &H1
'--------------------------------------------------------------
Public Enum MessageCenterPriority
    MESSAGE_ERROR = 10
    MESSAGE_WARNING = 11
    MESSAGE_INFO = 12
    MESSAGE_DEBUG = 13
End Enum

Enum Coordinates
    X = 0
    Y = 1
    Z = 2
End Enum
' ---------------------------------------------------------------------
'   MDL function declarations
' ---------------------------------------------------------------------
Declare Function mdlFile_find Lib "stdmdlbltin.dll" (ByVal outname As String, ByVal inname As String, ByVal envvar As String, ByVal iext As String) As Long
Declare Function mdlOutput_messageCenter Lib "stdmdlbltin.dll" (ByVal messagePriority As Long, ByVal pBriefMessage As String, ByVal pDetailedMessage As String, ByVal openAlertBox As Long) As Long
' ---------------------------------------------------------------------
'   Main entry point
'   keyin:
'   vba run modLogReferencePaths.Main
' ---------------------------------------------------------------------
Sub Main()
    On Error GoTo err_Main
    OutputMessageCentre "Text File Reader. Copyright ?2005 LA Solutions Ltd", "Reference File Logger: version no. " & CStr(nDateStamp)
    Dim fileName As String
    If (AskForTextFile(fileName)) Then
        Dim vertices()          As Point3d
        Dim nVertices           As Long
        nVertices = ParseTextFile(vertices, fileName)
        If (0 < nVertices) Then
            CreateLineString vertices, nVertices
        End If
    End If
    Exit Sub
    
err_Main:
    ReportError sMODULE_NAME, "Main"
End Sub
' ---------------------------------------------------------------------
'   ParseTextFile
'   Read and parse a text file into an array of coordinates.  We expect
'   each line of the text file  to contain three decimal numbers:
'   123.45,234.56,345.67
'   Blank lines and comments are ignored.  A comment is a line beginning
'   with a hash or semi-colon character ('#' or ';')
'   Returns: Number of coordinates parsed
' ---------------------------------------------------------------------
Function ParseTextFile(vertices() As Point3d, fileName As String) As Long
    ParseTextFile = 0
    On Error GoTo err_ParseTextFile
    
    Dim oFileSystem         As New Scripting.FileSystemObject
    Dim oFile               As Scripting.File
    Set oFile = oFileSystem.GetFile(fileName)
    
    Dim oTextStream         As Scripting.TextStream
    Set oTextStream = oFile.OpenAsTextStream(ForReading)
    
    Dim nVertex             As Long
    Dim point               As Point3d
    Dim line                As String
    nVertex = 0
    Do While (Not oTextStream.AtEndOfStream)
        line = Trim(oTextStream.ReadLine)
        If (ParseLine(point, line)) Then
            nVertex = nVertex + 1
            Debug.Print "Vertex [" & CStr(nVertex) & "]=" & CStr(point.X) & ", " & CStr(point.Y)
            ReDim Preserve vertices(0 To nVertex - 1)
            vertices(nVertex - 1) = point
        End If
    Loop
    oTextStream.Close
    Set oFileSystem = Nothing
    Debug.Print "Parsed " & CStr(nVertex) & " vertices "
    ParseTextFile = nVertex
    Exit Function
    
err_ParseTextFile:
    Set oFileSystem = Nothing
    ReportError sMODULE_NAME, "ParseTextFile"
End Function
' ---------------------------------------------------------------------
'   ParseLine
'   Returns True if line successfully parsed
' ---------------------------------------------------------------------
Function ParseLine(ByRef point As Point3d, line As String) As Boolean
    ParseLine = False
    On Error GoTo err_ParseLine
    Const SemiColon             As String = ";"
    Const Hash                  As String = "#"
    Const Comma                 As String = ","
    
    If (Not (SemiColon = Left(line, 1) Or Hash = Left(line, 1))) Then
        Debug.Print "Parse '" & line & "'"
        Dim values()            As String
        Dim index               As Integer
        values = Split(line, Comma)
        For index = LBound(values) To UBound(values)
            Select Case index
            Case X:
                point.X = CDbl(values(index))
            Case Y:
                point.Y = CDbl(values(index))
            Case Z:
                point.Z = CDbl(values(index))
            Case Else:
                Exit For
            End Select
        Next index
        ParseLine = True
    End If
    Exit Function
    
err_ParseLine:
    ReportError sMODULE_NAME, "ParseLine"
End Function
' ---------------------------------------------------------------------
'   CreateLineString
' ---------------------------------------------------------------------
Function CreateLineString(ByRef vertices() As Point3d, ByVal nVertices As Long) As Boolean
    CreateLineString = False
    On Error GoTo err_CreateLineString
    Dim oLine           As LineElement
    Set oLine = Application.CreateLineElement1(Nothing, vertices)
    oLine.Redraw msdDrawingModeNormal
    ActiveModelReference.AddElement oLine
    Exit Function
    
err_CreateLineString:
    ReportError sMODULE_NAME, "CreateLineString"
End Function
' ---------------------------------------------------------------------
'   AskForTextFile
'   Prompt user to locate a text file
'   Returns: True if file found
' ---------------------------------------------------------------------
Function AskForTextFile(ByRef fileName As String) As Boolean
    AskForTextFile = False
    On Error GoTo err_AskForLogFile
    Const MS_DATA     As String = "MS_DATA"
    fileName = ShowOpen("Coordinate File", "Text Files (*.txt)", "*.txt", ActiveWorkspace.ConfigurationVariableValue(MS_DATA))
    AskForTextFile = (vbNullString <> fileName)
    Debug.Print "Text File '" & fileName & "'"
    Exit Function
    
err_AskForLogFile:
    ReportError sMODULE_NAME, "AskForTextFile"
End Function
' ---------------------------------------------------------------------
'   ShowOpen    Open common dialog
'   Returns:    full path of file to open, or zero-length string if Cancel
'   Example:
'   StrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0)
'   StrFilter = StrFilter & "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
' ---------------------------------------------------------------------
Public Function ShowOpen( _
    strTitle As String, _
    Optional strFilterDescr As String = "All files (*.*)", _
    Optional strFilterSpec As String = "*.*", _
    Optional strInitDir As String = vbNullString) As String
    On Error GoTo Proc_Error

    Dim OFName          As OPENFILENAME
    Dim strFileFilter   As String, _
        strFileSelected As String

    'strFileFilter = "Microstation Files (*.dgn)" & Chr$(0) & "*.dgn" & Chr$(0)
    'strFileFilter = strFileFilter & "Autocad Files (*.dwg)" + Chr$(0) + "*.dwg" + Chr$(0)
    'strFileFilter = strFileFilter & "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
    strFileFilter = strFilterDescr & Chr$(0) & strFilterSpec & Chr$(0)
    With OFName
        .lStructSize = Len(OFName)
        .hWndOwner = 0&
        .hInstance = 0& 'App.hInstance
        'Select a filter
        .lpstrFilter = strFileFilter ' "Text Files (*.txt)" & Chr$(0) &"*.txt" & Chr$(0) & "All Files (*.*)" & Chr$(0) & "*.*" & Chr$(0)
        .lpstrFile = Space$(254)
        .nMaxFile = 255
        .lpstrFileTitle = Space$(254)
        .nMaxFileTitle = 255
        If (vbNullString <> strInitDir) Then _
            .lpstrInitialDir = strInitDir
        .lpstrTitle = strTitle ' "Select File"
        .flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_READONLY
    End With
    If GetOpenFileName(OFName) Then
        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

Proc_Exit:
    Exit Function
Proc_Error:
    ShowOpen = vbNullString
    MsgBox Err.Description
    Resume Proc_Exit
End Function
' ---------------------------------------------------------------------
'   OutputMessageCentre
'   Sends a message to MicroStation's message centre window.  Priority
'   is one of MESSAGE_ERROR, MESSAGE_WARNING, MESSAGE_INFO or MESSAGE_DEBUG
' ---------------------------------------------------------------------
Sub OutputMessageCentre(ByVal terse As String, Optional ByVal verbose As String = vbNullString, Optional ByVal priority As MessageCenterPriority = MESSAGE_INFO)

    If (vbNullString = verbose) Then
        mdlOutput_messageCenter priority, terse, terse, False
    Else
        mdlOutput_messageCenter priority, terse, verbose, False
    End If
End Sub
' ---------------------------------------------------------------------
'   ReportError
' ---------------------------------------------------------------------
Sub ReportError(moduleName As String, procName As String)
    MsgBox "Error no. " & CStr(Err.Number) & ": " & Err.Description & "." & vbNewLine & _
        "Occurred in procedure '" & procName & "'", vbOKOnly Or vbCritical, moduleName
End Sub