coutputdb.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 = "COutputDB"
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 'local copy
Private mLineNum As Integer
Private mEOF As Boolean
Private mCurLine As String
   
Private mConnection As ADODB.Connection
'Private mOpenTables() As ADODB.Recordset

' 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
Private mLeftFieldEnclosure As String
Private mRightFieldEnclosure As String
    
Public Function GetType() As otOutputSourceType
    GetType = otOutputSourceType.otDB
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

    ' Store the value into the fields collection.
    Set Fields = mOpenTables(CFIELDS, hTable)
    Fields.Remove value.name

    ' Store the value into the 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 "COutputDB", "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 "COutputDB", "EditRecord", Error(Err)
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 rs As ADODB.Recordset
        Dim sql As String
        Dim record As Collection
        Dim Field As COutputFieldProxy
        Dim index As Integer
        Dim isnum As Boolean

        ' Get the collection of fields.
        Set record = mOpenTables(CFIELDS, hTable)

        If mOpenTables(CSTATUS, hTable) = CSTATUS_EDITRECORD Then
            Dim whereClause As String
            
            ' If we are doing an UPDATE there MUST be a where clause.
            If mOpenTables(CWHERE_CLAUSE, hTable) = "" Then
                LogError "COutputDB", "UpdateTable", _
                    "Attempt to update record with no WHERE clause"
                UpdateTable = 1
                Exit Function
            End If
            
            ' Update an existing record in the table.
            sql = "Update " & mLeftFieldEnclosure & _
                    mOpenTables(CTABLE_NAME, hTable) & _
                    mRightFieldEnclosure & " set "

            ' Add the fields into the update string.
            For Each Field In record

                sql = sql & mLeftFieldEnclosure & _
                Field.name & mRightFieldEnclosure & "="

                ' Figure out if this is a numeric type.
                isnum = GOutputID.isNumeric(Field.dbType)

                ' Put single quotes around the value if it is
                ' anything but a number.
                If Not isnum Then
                    sql = sql & "'"
                End If
                
                sql = sql & Field.value
                
                If Not isnum Then
                    sql = sql & "'"
                End If
                
                sql = sql & ","
                               
            Next Field
            
            ' Remove the final comma.
            sql = left$(sql, Len(sql) - 1)
            
            ' Add on the where clause so that the
            ' correct record gets updated.
            sql = sql & " where " & _
                        mOpenTables(CWHERE_CLAUSE, hTable)
        Else
            Dim Values As String

            ' Insert a new record into the database.
            sql = "Insert into " & mLeftFieldEnclosure & _
                    mOpenTables(CTABLE_NAME, hTable) & _
                    mRightFieldEnclosure & " ("

            ' Add the fields to the insert string.
            For Each Field In record
                
                sql = sql & mLeftFieldEnclosure & _
                    Field.name & mRightFieldEnclosure & ","

                ' Figure out if this is a numeric type.
                isnum = GOutputID.isNumeric(Field.dbType)
                
                If Not isnum Then
                    Values = Values & "'"
                End If
                
                Values = Values & Field.value

                If Not isnum Then
                    Values = Values & "'"
                End If
            
                Values = Values & ","
            Next Field

            sql = left$(sql, Len(sql) - 1)
            Values = left$(Values, Len(Values) - 1)
            
            ' Add the values into the update string.
            sql = sql & ") VALUES(" & Values & ")"
        End If
        
        ' Do the sql.
        Set rs = mConnection.Execute(sql)
    End If
    
    ' From now on unless we are told different,
    ' this table is starting over.
    mOpenTables(CSTATUS, hTable) = CSTATUS_ADDNEWRECORD

    ' 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 "COutputDB", "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 "COutputDB", "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 sql As String
    Dim rsQuery As New ADODB.Recordset
    Dim TableName As String
    Dim where As String
    
    If IsEmpty(mOpenTables(CTABLE_NAME, hTable)) Then Exit Function

    TableName = mOpenTables(CTABLE_NAME, hTable)

' TODO update record to store any pending changes????

    sql = "Select * from " & TableName & " Where "

    ' String values must be enclosed in single quotes.
    If VarType(ForValue) = vbString Then
        where = ForValue.name + "='" + ForValue.value + "'"
    Else
        where = ForValue.name + "=" + ForValue.value
    End If

    ' Execute the query.
    rsQuery.Open sql & where, mConnection, _
                    adOpenStatic, adLockOptimistic
    
    ' Store the where clause so if we update this table, we will
    ' know what we are updating.
    If Len(mOpenTables(CWHERE_CLAUSE, hTable)) = 0 Then
        mOpenTables(CWHERE_CLAUSE, hTable) = where
    Else
        mOpenTables(CWHERE_CLAUSE, hTable) = _
            mOpenTables(CWHERE_CLAUSE, hTable) & " and " & where
    End If
    
    If rsQuery.BOF Or rsQuery.EOF Then
        ' Record not found.
        LocateFor = False
    Else
        ' Record found.
        LocateFor = True
    End If

    rsQuery.Close
    Set rsQuery = Nothing
    Exit Function

eHandler:
    LogError "COutputDB", "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.
    '**************************************************
    
    If Not mConnection Is Nothing Then
        If mConnection.State <> 0 Then
            mConnection.Close
        End If
        Set mConnection = Nothing
    End If
    
    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

    mEOF = False
    mLineNum = 0
    
    ' For access, use [].
    mLeftFieldEnclosure = ""
    mRightFieldEnclosure = ""
    
End Sub
Private Sub Class_Initialize()
    
    ReDim mOpenTables(0 To CNUMELEMENTS, 0 To 20)
    mFileName = ""
    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
    
    ' Close open files, reset defaults etc...
    ResetOutput
    
    ' If no database has been yet specified, ask for one.
    If Len(mFileName) = 0 Then
        frmODBCLogon.Show vbModal
        If GFormReturnValue <> vbOK Then
            OpenOutput = 1
            GCancelImport = True
            Exit Function
        End If
        fileName = frmODBCLogon.GetConnectString
        Unload frmODBCLogon
    End If
        
    '************************
    ' Open Connection Object.
    '************************
    
    ' Create Connection Object.
    Set mConnection = New ADODB.Connection
    mConnection.ConnectionString = mFileName
    
    ' Allow modifications by us, allow others to view only.
                        
    mConnection.Mode = adModeReadWrite
    mConnection.ConnectionTimeout = 30  ' Seconds
    
    ' Establish the connection.
    mConnection.Open
    
    Dim provider As String
    provider = mConnection.ConnectionString
    Dim left As Integer, right As Integer
    left = InStr(provider, "FIL=") + 4
    right = InStr(left, provider, ";")
    provider = Mid$(provider, left, right - left)
    If provider = "MS Access" Then
        mLeftFieldEnclosure = "["
        mRightFieldEnclosure = "]"
    End If
    
    Exit Function
   
eHandler:
    ' No password gives a huge error that is bigger than an integer.
    OpenOutput = IIf(Err < -32768 Or Err > 32768, 1, Err.Number)
    LogError "COutputDB", "OpenOutput", "From: " & Err.Source & _
                vbCrLf & Err.Description
End Function

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

Private Sub Class_Terminate()
    Set mOpenTables = Nothing
End Sub