cinputsql.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 = "CInputObjImplSQL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"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 mConnection As ADODB.Connection
Private mRecSet As ADODB.Recordset
Private mSQL As String

Private Const DEFAULT_TABLENAME = "SQLTable"

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

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

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
            
            ' SQL statements only return one table.
            SchemaArray(1, cnt) = DEFAULT_TABLENAME
            
            SchemaArray(2, cnt) = rs("TABLE_NAME") + "." + 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 "CInputObjImplSQL", "GetSchema", Error(Err), False
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 mRecSet.EOF = True Or mRecSet.BOF = True Then
        mEOF = True
    Else
        mCurLine = DEFAULT_TABLENAME
        
        For i = 0 To mRecSet.Fields.Count - 1
            mCurLine = mCurLine & "," & CStr(mRecSet.Fields(i))
        Next i
        
        GetNextLine = mCurLine
        mLineNum = mLineNum + 1

        ' Get the next record from the resultset.
        mRecSet.MoveNext
    End If

    
    Exit Function
    
eHandler:
    LogError "CInputObjImplSQL", "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

    ' Make sure the file is closed and all our internal
    ' variables are re-initialized.
    If Not mRecSet Is Nothing Then
        mRecSet.Close
        Set mRecSet = Nothing
    End If
    
    If Not mConnection Is Nothing Then
        If mConnection.State <> 0 Then
            mConnection.Close
        End If
        Set mConnection = Nothing
    End If

    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

    mSQL = InputBox("Enter a SQL String")
    Set mRecSet = mConnection.Execute(mSQL)
    
    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 "CInputObjImplSQL", "OpenInput", Error(Err)
End Function

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

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 "CInputObjImplSQL", "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 "CInputObjImplSQL", "Save", Error(Err)
End Function

Private Sub Class_Initialize()
    mvarFileName = ""
    ResetInput
End Sub

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