coutputtargettable.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 = "COutputTargetTable"
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

Private mName As String
Private mIndex As Integer
Private mFields As COutputTargetFields
Private mUniqueIndexedFields As Collection
Private mUniqueID As String
Private mHTable As Integer
Private mIgnoreMe As Boolean

Public Function Copy() As COutputTargetTable

    On Error GoTo eHandler
    Set Copy = Nothing

    Dim newObj As COutputTargetTable
    Set newObj = New COutputTargetTable

    newObj.name = Me.name
    
    Set Copy = newObj
    Set newObj = Nothing
    Exit Function

eHandler:
    LogError "COutputTargetTable", "Copy", Error(Err), False

End Function

Public Function StoreValue(Field As String, value As Variant) As Boolean
    On Error GoTo eHandler
    StoreValue = False
    Dim of As COutputTargetField
    
    Set of = mFields.ItemByName(Field)
    
    ' If the field we want to store to already contains a value.
    ' Then, we flush this entire record and start over.
    If of.ContainsValue = False Then
        of.value = value
    Else
        FlushFields
        of.value = value
    End If

    StoreValue = True
    Exit Function
eHandler:
    LogError "COutputTargetTable", "StoreValue", Error(Err)
    
End Function

Public Sub FlushFields(Optional StoreOutput As Boolean = True)

    ' If this table is inactive, get outtahere.
    If mIgnoreMe Then Exit Sub
    
    Dim of As COutputTargetField
    If StoreOutput And mHTable >= 0 Then
    
        If mUniqueIndexedFields.Count > 0 Then
        
            Dim UI As Boolean
            Dim FoundDuplicateRecord As Boolean
            FoundDuplicateRecord = False

            ' If any of our field objects are unique indexes, make
            ' sure we have something unique to store into them before
            ' writing values.
            For Each of In mUniqueIndexedFields

                ' Check for duplicate Unique Indexes.
                If of.ContainsValue Then
                    
                    Dim ForVal As New COutputFieldProxy
                    ForVal.name = of.name
                    ForVal.value = of.value

                    UI = GImport.GetOutputObject.LocateFor(mHTable, ForVal)

                    ' If we have a duplicate on a Unique Indexed field, flush
                    ' all our values without saving.
                    If UI Then
                        If GImport.GetSchemaObject.IgnoreUniqueIndexDuplicates Then
                            ' If we are discarding data that is already
                            ' in the DB, then flush this table and exit.
                            FlushFields False
                            Exit Sub
                        Else
                            ' We found the duplicate record
                            ' so exit the loop.
                            FoundDuplicateRecord = True
                            Exit For
                        End If
                    End If
                End If

                If GCancelImport Then Exit Sub

            Next of

            If FoundDuplicateRecord Then
                ' We found a duplicate record, and we are overwriting
                ' data that is already in the DB, so edit the duplicate
                ' record.
                GImport.GetOutputObject.EditRecord mHTable
            Else
                ' Add a new record to our table object.
                GImport.GetOutputObject.AddNewRecord mHTable
            End If
        
        Else    ' mUniqueIndexedFields > 0
            ' No unique fields to worry about, add a new record.
            GImport.GetOutputObject.AddNewRecord mHTable
            
        End If  ' mUniqueIndexedFields > 0
                
        Dim dirty As Boolean
        dirty = False
        
        ' Store our fields into the table.
        For Each of In GetFields
            If of.ContainsValue Then
                of.Flush mHTable
                dirty = True
            End If
            If GCancelImport Then Exit Sub
        Next of
    
        If dirty Then
            ' Update the record.
            GImport.GetOutputObject.UpdateTable mHTable
        End If
    Else    ' If not storing output then...
    
        ' Reset all the fields to contain nothing, but don't store.
        For Each of In GetFields
            of.ContainsValue = False
        Next of
        
    End If
End Sub

Public Function PrepareOutput() As Boolean
    Dim of As COutputTargetField
    
    ' Get a reference to an open table.
    mHTable = GImport.GetOutputObject.openTable(mName)
    If mHTable < 0 Then PrepareOutput = False
    
    Set mUniqueIndexedFields = New Collection
    For Each of In GetFields
        If of.UniqueIndexed Then
            mUniqueIndexedFields.Add item:=of
        End If
    Next of

    PrepareOutput = True
End Function

Public Sub CleanUp()
    FlushFields
    If mHTable >= 0 Then
        GImport.GetOutputObject.CloseTable mHTable
    End If
    Set mUniqueIndexedFields = Nothing
    mHTable = -1
End Sub

Public Property Get IgnoreMe() As Boolean
    IgnoreMe = mIgnoreMe
End Property

Public Property Let IgnoreMe(newVal As Boolean)
    mIgnoreMe = newVal
End Property

Public Function GetID() As String
    GetID = mUniqueID
End Function

Public Property Get name() As String
    name = mName
End Property
Public Property Let name(vName As String)
    mName = vName
End Property

Public Property Get index() As Integer
    index = mIndex
End Property
Public Property Let index(vIndex As Integer)
    mIndex = vIndex
End Property

Public Function GetFields() As COutputTargetFields
    Set GetFields = mFields
End Function

Public Function Load(ByRef arc As CArchive) As Boolean

    On Error GoTo eHandler
    
    Load = False
    Dim item As String, value As Variant, retVal As Integer
    Dim of As COutputTargetField
    
    ' Get the next line from the input file.
    Do
        retVal = arc.GetNextItem(item, value)
        
        ' Error, log it, then exit with error.
        If retVal = ArcRetType.cERROR Then
            arc.AddError
            GoTo done
            
        ' We are done with this object, leave.
        ElseIf retVal = ArcRetType.cENDITEM Then
            Exit Do
        End If
        
        Select Case item
            Case "NAME"
                mName = value
            Case "INDEX"
                mIndex = value
            Case "BEGIN TARGETFIELD"
                Set of = mFields.Add()
                of.Load arc
                Set of.parent = Me
                Set of = Nothing
            Case Else
                ' This line contains an unrecognized item.
                arc.AddError
                
        End Select
    Loop While True
    
    Load = True
done:
    Exit Function
    
eHandler:
    LogError "COutputTarget", "Load", Error(Err)
End Function

Public Function Save(ByRef arc As CArchive) As Boolean

    On Error GoTo eHandler
    
    Save = False
        
    arc.SaveItem aiBEGINTARGETTABLE
    arc.SaveItem aiVALUE, "NAME", mName
    arc.SaveItem aiVALUE, "INDEX", mIndex
    If Not mFields Is Nothing Then
        mFields.Save arc
    End If
    arc.SaveItem aiENDITEM
    
    Save = True
    Exit Function
    
eHandler:
    LogError "COuptutTargetTable", "Save", Error(Err)
    Exit Function
    
End Function

Private Sub Class_Initialize()
    Set mFields = New COutputTargetFields
    mUniqueID = GetUniqueID
    mHTable = -1
    mIgnoreMe = False
End Sub

Private Sub Class_Terminate()
    Set mFields = Nothing
End Sub