carchive.cls

Data monkey是一个强大的是数据传输和转换应用程序。使用DataMonkey用户可以把复杂的文本文件格式

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CArchive"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Description = "This class is used to save a file or to load a file."
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
' DataMonkey Data Conversion Application. Written by Theodore L. Ward
' Copyright (C) 2002 AstroComma Incorporated.
'
' This program is free software; you can redistribute it and/or
' modify it under the terms of the GNU General Public License
' as published by the Free Software Foundation; either version 2
' of the License, or (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.
'
' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
' The author may be contacted at:
' [e-mail] or [e-mail]

Option Explicit
Option Compare Text

'local variable(s) to hold property value(s)
Private mFileName As String 'local copy
Private mFileNum As Integer
Private mCurLine As String
Private mLineNum As Integer
Private mIndent As String
Private mInitialDirectory As String

Private mErrors(10) As String

Enum ArcRetType
    cVALUE
    cCOMMENT
    cBEGINITEM
    cENDITEM
    cENDOFFILE
    cERROR
    cSUCCESS
End Enum

Enum ArcItemType
    ' Generic items.
    aiCOMMENT
    aiENDITEM
    aiVALUE
    aiBLANKLINE

    ' Various specific items.
    aiBEGINIMPORT
    aiBEGINDATAPOINT
    aiBEGINCHECKPOINT
    aiBEGINACTION
    
    ' Specific Output object items.
    aiBEGINOUTPUTOBJECT
    aiBEGINOUTPUTSCHEMA
    aiBEGINTARGETTABLE
    aiBEGINTARGETFIELD
    aiBEGINOUTPUTLINK
    aiBEGINOUTPUTLINKS
    aiBEGINOUTPUTLINKSMANAGER
    
    aiBEGINPREFERENCES
    aiBEGINTEMPLATE
    
    aiBEGININPUTOBJECT
    aiBEGINOBJECT
End Enum


Public Property Let fileName(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.FileName = 5
    CloseFile
    Class_Initialize
    mFileName = vData
End Property


Public Property Get fileName() As String
Attribute fileName.VB_UserMemId = 0
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.FileName
    fileName = mFileName
End Property

Public Function OpenFile(Optional quiet As Boolean = True) As Boolean
    On Error GoTo eHandler
    OpenFile = False
    
    mFileNum = FreeFile
    Open mFileName For Binary Access Read Write As #mFileNum
    OpenFile = True
    Exit Function
    
eHandler:
    If Not quiet Then
        LogError "CArchive", "OpenFile", Error(Err)
    End If

    ' File Not Found.
    If Err = 53 Then
        mFileNum = -1
    End If
End Function

Public Function DeleteFile() As Boolean

    On Error GoTo eHandler
    
    DeleteFile = False
    
    '***************************************
    ' If the file is already open, close it.
    '***************************************
    
    If mFileNum <> -1 Then
        Close mFileNum
    End If
    
    '************************************************
    ' Delete the file, and then close the filehandle.
    '************************************************
    
    mFileNum = FreeFile
    Open mFileName For Output As mFileNum
    Close mFileNum
    mFileNum = -1
    DeleteFile = True
    Exit Function
    
eHandler:
    MsgBox Error(Err)
End Function

Public Sub DisplayErrors()
End Sub

Public Function SaveItem(ItemType As ArcItemType, Optional item As String = "", Optional value As Variant = "") As Boolean
    SaveItem = False
    On Error GoTo eHandler
    Dim tstr As String
    Dim i As Integer
    
    item = Trim(item)
    
    If mFileNum = -1 Then
        If Not Me.OpenFile() Then Exit Function
    End If
    
    mLineNum = mLineNum + 1
    
    Select Case ItemType
    
        Case aiBEGINIMPORT
            Put #mFileNum, , mIndent & "BEGIN IMPORT=" & item & vbCrLf
            mIndent = mIndent & Space(4)

        Case aiBEGINTEMPLATE
            Put #mFileNum, , mIndent & "BEGIN TEMPLATE=" & item & vbCrLf
            mIndent = mIndent & Space(4)

        Case aiBEGINDATAPOINT
            Put #mFileNum, , mIndent + "BEGIN DATAPOINT=" + item + vbCrLf
            mIndent = mIndent + Space(4)
        
        Case aiBEGINCHECKPOINT
            Put #mFileNum, , mIndent + "BEGIN CHECKPOINT=" + item + vbCrLf
            mIndent = mIndent + Space(4)
        
        Case aiBEGINACTION
            Put #mFileNum, , mIndent + "BEGIN ACTION=" + item + vbCrLf
            mIndent = mIndent + Space(4)
            
        Case aiBEGINOUTPUTOBJECT
            Put #mFileNum, , mIndent + "BEGIN OUTPUTOBJECT=" + item + vbCrLf
            mIndent = mIndent + Space(4)
        
        Case aiBEGINTARGETTABLE
            Put #mFileNum, , mIndent + "BEGIN TARGETTABLE=" + item + vbCrLf
            mIndent = mIndent + Space(4)
        
        Case aiBEGINTARGETFIELD
            Put #mFileNum, , mIndent + "BEGIN TARGETFIELD=" + item + vbCrLf
            mIndent = mIndent + Space(4)
        
        Case aiBEGINOUTPUTSCHEMA
            Put #mFileNum, , mIndent + "BEGIN OUTPUTSCHEMA=" + item + vbCrLf
            mIndent = mIndent + Space(4)
        
        Case aiBEGINOUTPUTLINK
            Put #mFileNum, , mIndent + "BEGIN OUTPUTLINK=" + item + vbCrLf
            mIndent = mIndent + Space(4)

        Case aiBEGINOUTPUTLINKS
            Put #mFileNum, , mIndent + "BEGIN OUTPUTLINKS=" + item + vbCrLf
            mIndent = mIndent + Space(4)
        
        Case aiBEGINOUTPUTLINKSMANAGER
            Put #mFileNum, , mIndent + "BEGIN OUTPUTLINKSMANAGER=" + item + vbCrLf
            mIndent = mIndent + Space(4)
        
        Case aiBEGINPREFERENCES
            Put #mFileNum, , mIndent + "BEGIN PREFERENCES=" & item & vbCrLf
            mIndent = mIndent + Space(4)
            
        Case aiBEGININPUTOBJECT
            Put #mFileNum, , mIndent + "BEGIN INPUTOBJECT=" & item & vbCrLf
            mIndent = mIndent + Space(4)

        Case aiBEGINOBJECT
            Put #mFileNum, , mIndent + "BEGIN OBJECT=" & item & vbCrLf
            mIndent = mIndent + Space(4)
            
        Case aiENDITEM
            i = Len(mIndent)
            If i < 4 Then
                LogError "CArchive", "SaveItem", "Mismatched BEGIN/IF block at line#" + str(mLineNum), False
            Else
                mIndent = left$(mIndent, i - 4)
            End If
    
            Put #mFileNum, , mIndent + "END " + item + vbCrLf
            
        Case aiCOMMENT
            ' For some reason, you have to store these to a string
            ' first, or you get garbage in the output strings.
            
            Put #mFileNum, , vbCrLf
            tstr = mIndent & String(Len(item) + 3, "*") & vbCrLf
            Put #mFileNum, , tstr
            tstr = mIndent & "* " & item & vbCrLf
            Put #mFileNum, , tstr
            tstr = mIndent & String(Len(item) + 3, "*") & vbCrLf
            Put #mFileNum, , tstr

        Case aiVALUE
            Put #mFileNum, , mIndent + item + " = " + CStr(value) + vbCrLf
            
        Case aiBLANKLINE
            Put #mFileNum, , "" + vbCrLf
            
        Case Else
            mLineNum = mLineNum - 1
            
    End Select
    
    SaveItem = True
    Exit Function
    
eHandler:
    LogError "CArchive", "SaveItem", Error(Err), False
End Function

Public Function GetCurrentItem(item As String, value As Variant) As ArcRetType
    GetCurrentItem = ParseLine(item, value)
End Function

Public Sub AddError()
    LogError "CArchive", "AddError", "Error at line " & CStr(mLineNum) & " = '" & mCurLine & "'", False
End Sub

Public Function GetNextItem(item As String, value As Variant) As ArcRetType

    GetNextItem = ArcRetType.cENDOFFILE

    On Error GoTo eHandler
        
    If mFileNum = -1 Then
        If Not Me.OpenFile Then
            GetNextItem = ArcRetType.cERROR
            Exit Function
        End If
    End If
    
    '******************************
    ' Read the next non-blank line.
    '******************************
    
    Do While Not EOF(mFileNum)
    
        Line Input #mFileNum, mCurLine
        mCurLine = Trim(mCurLine)
        If Len(mCurLine) > 0 Then
            GetNextItem = ParseLine(item, value)
            If GetNextItem <> cCOMMENT Then
                Exit Do
            End If
        End If
    Loop
    
    Exit Function
    
eHandler:
    GetNextItem = ArcRetType.cERROR
End Function

Public Function CloseFile() As Boolean

    CloseFile = False
    
    On Error GoTo eHandler
    
    '***************************************
    ' If the file is already open, close it.
    '***************************************
    
    If mFileNum <> -1 Then
        Close mFileNum
    End If
    
    mFileNum = -1
    CloseFile = True
    Exit Function
    
eHandler:
    MsgBox Error(Err)

End Function

Private Function ParseLine(ByRef item As String, ByRef value As Variant) As ArcRetType

    On Error GoTo eHandler
    ParseLine = ArcRetType.cERROR
    
    Dim i As Integer
    i = InStr(mCurLine, "=")
    value = ""
    item = ""
    If i > 0 Then
        item = Trim(left$(mCurLine, i - 1))
        value = Trim(right$(mCurLine, Len(mCurLine) - i))
        If left$(mCurLine, 5) = "BEGIN" Then
            ParseLine = ArcRetType.cBEGINITEM
        Else
            ParseLine = ArcRetType.cVALUE
        End If
        
    ' Comments begin with commas, well include blanks lines too.
    ElseIf left$(mCurLine, 1) = "*" Or Len(mCurLine) = 0 Then
        item = mCurLine
        ParseLine = ArcRetType.cCOMMENT
        ParseLine = cCOMMENT
        
    ElseIf left$(mCurLine, 3) = "END" Then
        item = mCurLine
        ParseLine = ArcRetType.cENDITEM
    Else
        ParseLine = ArcRetType.cERROR
    End If
    
    Exit Function
    
eHandler:
  MsgBox Error(Err)
End Function

Private Sub Class_Initialize()
    mLineNum = 0
    mFileNum = -1
    mFileName = ""
    mCurLine = ""
    mIndent = ""
    mInitialDirectory = GWorkingDirectory
End Sub

Public Property Let InitialBrowseDirectory(directory As String)
    mInitialDirectory = directory
End Property
Public Property Get InitialBrowseDirectory() As String
    InitialBrowseDirectory = mInitialDirectory
End Property

Public Function BrowseFileOpen(ByRef DlgTitle As String, _
                    Optional fileName As String = "", _
                    Optional Filter As String = "All Files (*.*)|*.*", _
                    Optional OpenFile As Boolean = True) As Boolean
    
    On Error GoTo eHandler
    BrowseFileOpen = False
    Dim EverythingsCool As Boolean

    ' If we are verifying the file is openable, stay in the loop
    ' until we get a cancel, or we get a good filename.
    Do
        ' Get the name of the file the user wants to import.
        With fMainForm.dlgCommonDialog
            .fileName = fileName
            .Filter = Filter
            .DialogTitle = DlgTitle
            On Error Resume Next
            .ShowOpen
            If Err = 32755 Then ' Dialog cancelled.
                EverythingsCool = False
                Exit Do
            End If
            On Error GoTo eHandler
            mFileName = Trim(.fileName)
        End With
    
        If OpenFile Then
            ' We have a filename, open it to make sure it exists.
            EverythingsCool = Me.OpenFile(False)
        Else
            ' We have a name, good enough.
            EverythingsCool = True
        End If

    Loop While Not EverythingsCool And OpenFile
    
    BrowseFileOpen = EverythingsCool
    
    Exit Function

eHandler:
    LogError "CArchive", "BrowseFileOpen", Error(Err), False

End Function

Public Function BrowseFileSave(ByRef DlgTitle As String, _
            Optional fileName As String = "", _
            Optional Filter As String = "All Files (*.*)|*.*", _
            Optional OpenFile As Boolean = True, _
            Optional VerifyForExisting As Boolean = True) As Boolean

    On Error GoTo eHandler
    BrowseFileSave = False
    
    Dim EverythingsCool As Boolean
    EverythingsCool = False
    
    Do
        ' Get the name of the file the user wants to import.
        With fMainForm.dlgCommonDialog
            .fileName = fileName
            .Filter = Filter
            .DialogTitle = DlgTitle
            On Error Resume Next
            .ShowSave
            If Err = 32755 Then ' Cancel
                EverythingsCool = False
                Exit Do
            End If
            
            On Error GoTo eHandler
            
            ' The browsebox won't return more than 3 character extension.
            If right$(.fileName, 3) = "imp" And _
                right$(.fileName, 6) <> "import" Then
                .fileName = .fileName & "ort"
            End If
            
            mFileName = Trim(.fileName)
        
        End With

        If VerifyForExisting Then
            Dim i As Integer, t As Integer
            i = FreeFile
            On Error Resume Next
            Open mFileName For Input As #i
            If Err = 0 Then ' File already exists.
                On Error GoTo eHandler
                Close i
                t = MsgBox("The file '" & mFileName & _
                        "' already exists." & vbCrLf & "Overwrite file?", _
                        vbYesNoCancel Or vbQuestion, _
                        "Verify")
                If t = vbNo Then
                    GoTo LoopBottom
                ElseIf t = vbCancel Then
                    EverythingsCool = False
                    Exit Do
                End If
            End If
            On Error GoTo eHandler
        End If

        If OpenFile Then
            ' We have a filename, open it to make sure it exists.
            EverythingsCool = Me.OpenFile(False)
        Else
            ' We have a name, good enough.
            EverythingsCool = True
        End If

LoopBottom:
    Loop While Not EverythingsCool And OpenFile

    BrowseFileSave = EverythingsCool
    Exit Function

eHandler:
    LogError "CArchive", "BrowseFileSave", Error(Err), False

End Function