cinputdb.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 = "CInputObjImplDB"
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

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

Private mCurTable As ADODB.Recordset
Private mCurTableNameIndex As Integer
Private mConnection As ADODB.Connection
Private mTableNames As Collection

Public Function SupportsGetSchema() As Boolean
    SupportsGetSchema = True
End Function

' This function will import a schema and return a 2 dimensional array
' in the form Array(TableName, FieldName) for each schema element.
Public Function GetSchema() As String()

    On Error GoTo eHandler
    
    Dim Connection As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim cnt As Integer
    Dim SchemaArray() As String
    Dim ValidTableNames As New Collection
    
    Set Connection = New ADODB.Connection
    Connection.Open mvarFileName
    
    ' Store all the non-system table names first, when we get field names
    ' there is no information about what type of table the field goes with.
    Set rs = Connection.OpenSchema(adSchemaTables)
    Do Until rs.EOF
        If rs("TABLE_TYPE") = "TABLE" Then
            Dim tblName As String
            tblName = rs("TABLE_NAME")
            ValidTableNames.Add tblName, tblName
        End If
        rs.MoveNext
    Loop

    ' If there are no tables in the database, exit.
    If ValidTableNames.Count = 0 Then Exit Function
    
    '*******************************
    ' Get the Table and Field Names.
    '*******************************
    
    cnt = 0
    ReDim SchemaArray(2, 20)    ' Allocate some space to our array.

    ' Open a recordset with all the column (field) information.
    Set rs = Connection.OpenSchema(adSchemaColumns)

    Dim tableIsValid
    
    Do Until rs.EOF
        
        On Error Resume Next
        ' Try to get the tablename from the valid table names collection.
        ' If it doesn't exist, we will get error #5
        tableIsValid = ValidTableNames(rs("table_name"))
        tableIsValid = (Err = 0)
        On Error GoTo eHandler
        
        ' Add an entry to our array if our table is valid.
        If tableIsValid Then
            cnt = cnt + 1
            If cnt = UBound(SchemaArray, 2) Then
                ReDim Preserve SchemaArray(2, cnt + 20)
            End If
            
            SchemaArray(1, cnt) = rs("TABLE_NAME")
            SchemaArray(2, cnt) = rs("COLUMN_NAME")
        End If
        rs.MoveNext
    Loop
    
    ' Size the array to exactly the right size, so the caller will know
    ' how many elements the array contains (via ubound).
    ReDim Preserve SchemaArray(2, cnt)
    
    rs.Close
    Set rs = Nothing
    
    GetSchema = SchemaArray
    
done:
    Connection.Close
    Set Connection = Nothing
    Exit Function

eHandler:
    LogError "CInputObjImplDB", "GetSchema", Error(Err), False
End Function

Private Function ReadTableNames() As Integer
    On Error GoTo eHandler
    Dim rs As ADODB.Recordset
    
    ReadTableNames = 0
    If mConnection.State = 0 Then Exit Function

    ' Open a recordset with all of the table information.
    Set rs = mConnection.OpenSchema(adSchemaTables)
    
    ' Reset current table names list.
    mCurTableNameIndex = 0
    Set mCurTable = Nothing
    Set mTableNames = Nothing
    Set mTableNames = New Collection

    Do Until rs.EOF
        ' Make sure its a regular table.
        If rs("TABLE_TYPE") = "TABLE" Then
            ' Add the Tablename to our collection.
            mTableNames.Add CStr(rs("TABLE_NAME"))
        End If
        rs.MoveNext
    Loop

    ' Close the recordset.
    rs.Close
    Set rs = Nothing
    
done:
    ReadTableNames = mTableNames.Count
    Exit Function

eHandler:
    LogError "CInputObjImplDB", "ReadTableNames", Error(Err), False

End Function

Public Function GetLineNumber() As Long
    GetLineNumber = mLineNum
End Function

Public Function GotoLine(LineNumber As Long) As Long
    mLineNum = LineNumber
End Function

Public Function GetNextLine() As String
    On Error GoTo eHandler
    Dim i As Integer
    Dim openTable As Boolean
    
    GetNextLine = ""
    mCurLine = ""
   
    ' If end of file, or we don't have a filename, exit.
    If mEOF Or mvarFileName = "" Then Exit Function
    
    ' Open the input file if not already open.
    If mConnection.State = 0 Then
        If OpenInput <> 0 Then Exit Function
    End If

    If mCurTable Is Nothing Then
        Set mCurTable = New ADODB.Recordset
        openTable = True
    ElseIf mCurTable.State = 0 Then
        openTable = True
    ElseIf mCurTable.EOF Then
        openTable = True
    Else
        mCurTable.MoveNext
        openTable = IIf(mCurTable.EOF, True, False)
    End If

    If openTable Then
        If mCurTableNameIndex = mTableNames.Count Then
            If mCurTable.State <> 0 Then mCurTable.Close
            mEOF = True
            Exit Function
        Else
            If mCurTable.State <> 0 Then mCurTable.Close
            Set mCurTable = Nothing
            Set mCurTable = New ADODB.Recordset

            mCurTableNameIndex = mCurTableNameIndex + 1
            
            Set mCurTable.ActiveConnection = mConnection
            mCurTable.LockType = adLockOptimistic
            mCurTable.Open mTableNames(mCurTableNameIndex), , adOpenDynamic
            If mCurTable.State = 0 Or mCurTable.EOF Or mCurTable.BOF Then
                mEOF = True
                Exit Function
            End If
        End If
    End If
    
    ' Construct a "Line" of input from the table name and all of
    ' the field values from this row.
    mCurLine = mTableNames(mCurTableNameIndex)
    For i = 0 To mCurTable.Fields.Count - 1
        mCurLine = mCurLine & "," & CStr(mCurTable.Fields(i))
    Next i
    
    GetNextLine = mCurLine
    mLineNum = mLineNum + 1
    
    Exit Function
    
eHandler:
    LogError "CInputObjImplDB", "GetNextLine", Error(Err)
'    Resume
End Function

Public Function GetCurrentLine() As String
    GetCurrentLine = mCurLine
End Function

Public Function IsEOF() As Boolean
    IsEOF = mEOF
End Function

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

Public Sub ResetInput()
    On Error Resume Next
    
    Dim i As Integer

    mCurTable.Close

    ' 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

    Set mTableNames = Nothing
    Set mTableNames = New Collection

    mEOF = False
    mLineNum = 0

End Sub

Public Function OpenInput() As Integer
    On Error GoTo eHandler
    OpenInput = 0
    
    ' Close open files, reset defaults etc...
    ResetInput
    
    ' If no database has been yet specified, ask for one.
    If Len(mvarFileName) = 0 Then
        frmODBCLogon.Show vbModal
        If GFormReturnValue <> vbOK Then
            OpenInput = 1
            GCancelImport = True
            Exit Function
        End If
        fileName = frmODBCLogon.GetConnectString
        Unload frmODBCLogon
    End If
        
    ' Create Connection Object.
    Set mConnection = New ADODB.Connection
    mConnection.ConnectionString = mvarFileName
    
    ' Allow modifications by us, allow others to view only.
    mConnection.Mode = adModeRead
    mConnection.ConnectionTimeout = 30  ' Seconds
    
    ' Establish the connection.
    mConnection.Open

    ' Get a list of all table names.
    ReadTableNames

    Exit Function
   
eHandler:
    ' No password gives a huge error that is bigger than an integer.
    If Err < -32768 Or Err > 32767 Then
        OpenInput = 1
    Else
        OpenInput = Err
    End If
    mvarFileName = ""
    LogError "CInputObjImplDB", "OpenInput", Error(Err)
End Function

Public Sub CloseInput()
    ' Close open files, etc...
    ResetInput
End Sub

Private Sub Class_Initialize()

    Set mTableNames = New Collection
    Set mConnection = New ADODB.Connection
    Set mCurTable = New ADODB.Recordset
    mCurTableNameIndex = 0
    
    mvarFileName = ""
    ResetInput
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    mCurTable.Close
    mConnection.Close
    Set mCurTable = Nothing
    Set mTableNames = Nothing
    Set mConnection = Nothing
End Sub

' Load the gimport object from the file opened in the global Archive
' object.
Public Function Load(arc As CArchive) As Boolean
 
    On Error GoTo eHandler
    Dim value As Variant, item As String, retVal As Integer
    
    Load = False
    Do
        retVal = arc.GetNextItem(item, value)

        ' Error, log it, then exit with error.
        If retVal = ArcRetType.cERROR Then
            arc.AddError
            GoTo terminate
            
        ' We are done with this object, leave.
        ElseIf retVal = ArcRetType.cENDITEM Then
            Exit Do
        End If

    Loop While True
    Load = True
    
terminate:
    Exit Function
    
eHandler:
    LogError "CInputObjImplDB", "Load", Error(Err)
End Function

Public Function Save(ByRef arc As CArchive) As Boolean
    On Error GoTo eHandler
    Save = False

    arc.SaveItem aiBEGINOBJECT
    arc.SaveItem aiENDITEM
    Save = True
    Exit Function

eHandler:
    LogError "CInputObjImplDB", "Save", Error(Err)
End Function