coutputxml.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 = "COutputObjImplXML"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
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 Base 0

'local variable(s) to hold property value(s)
Private mFileName As String
Private mLineNum As Integer
Private mEOF As Boolean
Private mCurLine As String
Private mFileNum As Integer

' Define an array to hold our table names/field collections
Private mOpenTables As Variant

' Define indexes into mOpenTables
Private Const CTABLE_NAME = 0
Private Const CFIELDS = 1
Private Const CSTATUS = 2
Private Const CWHERE_CLAUSE = 3
Private Const CNUMELEMENTS = 4  ' Number of items above.

' Status Settings for above array.
Private Const CSTATUS_ADDNEWRECORD = 1
Private Const CSTATUS_EDITRECORD = 2
    
Public Function GetType() As otOutputSourceType
    GetType = otOutputSourceType.otXML
End Function

Private Function StoreValueAt(hTable As Integer, _
                                value As COutputFieldProxy) As Integer
    StoreValueAt = 0
    On Error Resume Next
    Dim Fields As Collection
    
    If mOpenTables(CFIELDS, hTable) Is Nothing Then Exit Function

    ' Make sure the value isn't already in the fields collection.
    Set Fields = mOpenTables(CFIELDS, hTable)
    Fields.Remove value.name

    ' Store the value into the pseudo-database.
    Fields.Add value, value.name
    Exit Function

End Function

Public Function StoreValue(hTable As Integer, value As COutputFieldProxy) As Integer
    StoreValue = StoreValueAt(hTable, value)
End Function

Public Function openTable(TableName As String) As Integer
    Dim i As Integer
    
    openTable = -1
    
    ' Look for a space to store an new table in our array.
    For i = LBound(mOpenTables, 2) To UBound(mOpenTables, 2)
        
        ' Found a space!
        If mOpenTables(CFIELDS, i) Is Nothing Then
            openTable = OpenTableAt(i, TableName)
            Exit Function
        End If
    Next i
    
    ' Add some more space to store open tables.
    ReDim Preserve mOpenTables(CNUMELEMENTS, _
                        0 To UBound(mOpenTables, 2) + 20)
    openTable = OpenTableAt(i, TableName)

End Function

Public Function AddNewRecord(hTable As Integer) As Integer
    On Error GoTo eHandler
    AddNewRecord = 0
    mOpenTables(CSTATUS, hTable) = CSTATUS_ADDNEWRECORD

' Flush current?
    
    Exit Function

eHandler:
    AddNewRecord = IIf(Err < -32768 Or Err > 32768, 1, Err.Number)
    LogError "COutputObjImplXML", "AddNewRecord", Error(Err)
End Function

Public Function EditRecord(hTable As Integer) As Integer
    On Error GoTo eHandler
    EditRecord = 0
    mOpenTables(CSTATUS, hTable) = CSTATUS_EDITRECORD
    Exit Function

eHandler:
    EditRecord = Err
    LogError "COutputObjImplXML", "EditRecord", Error(Err)
End Function

' Replace these characters so they won't screw up XML.
Private Function xmlEscape(ByRef str As String) As String
    xmlEscape = Replace(str, "&", "&amp;")
    xmlEscape = Replace(xmlEscape, "<", "&lt;")
    xmlEscape = Replace(xmlEscape, ">", "&gt;")
    xmlEscape = Replace(xmlEscape, """", "&quot;")
    xmlEscape = Replace(xmlEscape, "'", "&apos;")
End Function

Public Function UpdateTable(hTable As Integer) As Integer
    On Error GoTo eHandler
    UpdateTable = 0
    
    ' Make sure we are updating a valid table.
    If Not mOpenTables(CFIELDS, hTable) Is Nothing Then
        Dim record As Collection
        Dim Field As COutputFieldProxy
        Dim outStr As String

        If mFileNum < 0 Then
            LogError "COutputObjImplXML", "UpdateTable", "Output file not open"
            UpdateTable = 1
            Exit Function
        End If
        
        ' Get the collection of fields.
        Set record = mOpenTables(CFIELDS, hTable)

        ' Set the table name tag.
        Print #mFileNum, "<" & mOpenTables(CTABLE_NAME, hTable) & ">"
        
        ' Add the fields to the output.
        For Each Field In record
            outStr = "    <" & Field.name & ">" & _
                            xmlEscape(Field.value) & _
                            "</" & Field.name & ">"
            Print #mFileNum, outStr
        Next
        
        ' Close the table name tag.
        Print #mFileNum, "</" & mOpenTables(CTABLE_NAME, hTable) & ">"
    End If
    
    ' Reset the field collection so we don't end up with
    ' leftover field values next time.
    Set mOpenTables(CFIELDS, hTable) = Nothing
    Set mOpenTables(CFIELDS, hTable) = New Collection
    mOpenTables(CWHERE_CLAUSE, hTable) = ""
    Exit Function
    
eHandler:
    UpdateTable = IIf(Err < -32768 Or Err > 32768, 1, Err.Number)
    LogError "COutputObjImplXML", "UpdateTable", Error(Err)
   
End Function

Public Sub CloseTable(hTable As Integer)
    On Error Resume Next
    Set mOpenTables(CFIELDS, hTable) = Nothing
    mOpenTables(CTABLE_NAME, hTable) = vbEmpty
    mOpenTables(CWHERE_CLAUSE, hTable) = ""
    mOpenTables(CSTATUS, hTable) = CSTATUS_ADDNEWRECORD
End Sub

' Open a table and store the reference in our opentable array at
' the given offset.
Private Function OpenTableAt(hTable As Integer, TableName As String) As Integer
    OpenTableAt = -1
    On Error GoTo eHandler

    Set mOpenTables(CFIELDS, hTable) = Nothing
    mOpenTables(CTABLE_NAME, hTable) = TableName
    Set mOpenTables(CFIELDS, hTable) = New Collection
    mOpenTables(CSTATUS, hTable) = CSTATUS_ADDNEWRECORD
    mOpenTables(CWHERE_CLAUSE, hTable) = ""
    OpenTableAt = hTable

    Exit Function

eHandler:
    LogError "COutputObjImplXML", "OpenTableAt", Error(Err)
End Function

' LocateFor
' If a field named FieldName is found in the table named TableName
' and that field contains the value specified in ForValue then
' True is returned.
' Otherwise False is returned.
Public Function LocateFor(hTable As Integer, _
                            ForValue As COutputFieldProxy) As Boolean
                            
    On Error GoTo eHandler
    LocateFor = False
    Dim TableName As String
    
    If IsEmpty(mOpenTables(CTABLE_NAME, hTable)) Then Exit Function
    TableName = mOpenTables(CTABLE_NAME, hTable)
    
    Exit Function

eHandler:
    LogError "COutputObjImplXML", "LocateFor", Error(Err)
End Function

Public Property Let fileName(ByVal vData As String)
    mFileName = vData
End Property

Public Property Get fileName() As String
    fileName = mFileName
End Property

Public Sub ResetOutput()

    Dim i As Integer

    '**************************************************
    ' Make sure the file is closed and all our internal
    ' variables are re-initialized.
    '**************************************************

    For i = LBound(mOpenTables, 2) To _
            UBound(mOpenTables, 2)
        mOpenTables(CTABLE_NAME, i) = vbEmpty
        Set mOpenTables(CFIELDS, i) = Nothing
        mOpenTables(CSTATUS, i) = CSTATUS_ADDNEWRECORD
        mOpenTables(CWHERE_CLAUSE, i) = ""
    Next i

    If mFileNum <> -1 Then
        Print #mFileNum, "</DATA>"
        Close mFileNum
        mFileNum = -1
    End If
    mEOF = False
    mLineNum = 0
    
End Sub

Private Sub Class_Initialize()
    ReDim mOpenTables(0 To CNUMELEMENTS, 0 To 20)
    mFileName = ""
    mFileNum = -1
    ResetOutput
End Sub

Public Function GetTableName(hTable As Integer) As String
    GetTableName = mOpenTables(CTABLE_NAME, hTable)
End Function

Public Function OpenOutput() As Integer
    On Error GoTo eHandler
    OpenOutput = 0
    
    ' If not database has been yet specified, ask for one.
    If Len(mFileName) = 0 Then
        With fMainForm.dlgCommonDialog
        'set the flags and attributes of the
        'common dialog control
        .DialogTitle = "Select file to store data"
        .Filter = "XML files (*.xml)|*.xml|All Files (*.*)|*.*"
        .ShowSave
        If Len(.fileName) = 0 Then Exit Function
        mFileName = .fileName
        End With
    End If
    Dim sFile As String

    mFileNum = FreeFile
    Open mFileName For Output As #mFileNum
    
    ' Write the xml header.
    Print #mFileNum, "<?xml version=""1.0"" encoding=""ISO-8859-1""?>"
    Print #mFileNum, "<DATA>"

    Exit Function

eHandler:
    If Err <> 32755 Then    ' (dialog cancelled)
        LogError "COutputObjImplXML", "OpenOutput", Error(Err)
    End If
    mFileNum = -1
    OpenOutput = Err
End Function

Public Sub CloseOutput()
    ' Close open files, etc...
    ResetOutput
End Sub

Private Sub Class_Terminate()
    CloseOutput
    Set mOpenTables = Nothing
End Sub