'This Program use for a checking two databse(Ms-Access)

'If Source table not exist in destination table then create it

'If Source table's field not exist in destination table then add that col.

'Open 2 Connection ... One for Source Database Another For Destination Database

Private Type ColStruct

    FieldName As String
    FieldType As String
    CHAR_LENGTH As Integer
    NUM_PRECESION As Integer
    NUM_SCALE As Integer

End Type

Dim ObjCol() As ColStruct

Private Sub Command1_Click()

Dim dbTableList As New ADODB.Recordset
Dim dbFieldList As New ADODB.Recordset
Dim dbIndexList As New ADODB.Recordset

Dim VarTemptbl As String, BolChkTable As Boolean, BolChkCol As Boolean
Dim DbTableField As ADODB.Fields
Dim StrTableName As String, StrColName As String

Dim SourceTables(255) As String, IntI As Integer, IntJ As Integer, IntTables As Integer, Intcols As Integer

Dim columnTypes(255)

    columnTypes(0) = "Empty"
    columnTypes(2) = "SmallInt"
    columnTypes(3) = "Integer"
    columnTypes(4) = "Real"
    columnTypes(5) = "Double"
    columnTypes(6) = "Currency"
    columnTypes(7) = "Date"
    columnTypes(8) = "BSTR"
    columnTypes(9) = "IDispatch"
    columnTypes(10) = "Error Code"
    columnTypes(11) = "Boolean"
    columnTypes(12) = "Variant"
    columnTypes(13) = "IUnknown"
    columnTypes(14) = "Decimal"
    columnTypes(16) = "TinyInt"
    columnTypes(17) = "Unsigned TinyInt (BYTE)"
    columnTypes(18) = "Unsigned Small Int (WORD)"
    columnTypes(19) = "Unsigned Int (DWORD)"
    columnTypes(20) = "BigInt"
    columnTypes(21) = "Unsigned Big Int"
    columnTypes(64) = "FileTime"
    columnTypes(72) = "Unique Identifier (GUID)"
    columnTypes(128) = "Binary"
    columnTypes(129) = "Char"
    columnTypes(130) = "nChar"
    columnTypes(131) = "Numeric"
    columnTypes(132) = "User Defined (UDT)"
    columnTypes(133) = "DBDate"
    columnTypes(134) = "DBTime"
    columnTypes(135) = "SmallDateTime"
    columnTypes(136) = "Chapter"
    columnTypes(138) = "Automation (PropVariant)"
    columnTypes(139) = "VarNumeric"
    columnTypes(200) = "VarChar"
    columnTypes(201) = "Text"
    columnTypes(202) = "nVarChar"
    columnTypes(203) = "nText"
    columnTypes(204) = "VarBinary"
    columnTypes(205) = "Image"

' Find how many tables in Source databse
Set dbTableList = strcn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE"))

If dbTableList.RecordCount = 0 Then
    MsgBox "Source Databse Empty"
    dbTableList.Close
    Exit Sub
End If

IntTables = 0
'All Source tables add in One Array
Do Until dbTableList.EOF

        SourceTables(IntTables) = Trim(dbTableList!table_name & "")
        dbTableList.MoveNext
        If dbTableList.EOF = True Then Exit Do
        IntTables = IntTables + 1
Loop

dbTableList.Close
Set dbTableList = Nothing
' Find how many tables in Destination databse
Set dbTableList = strDcn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE"))

' If Destination table Empty then Create all Tables in It
If dbTableList.RecordCount = 0 Then
    For IntI = 0 To IntTables
        Call CreateTable(SourceTables(IntI))
    Next IntI
    Exit Sub
End If

'If Destination Tables Exist then Check is there any table Not Present ,
'If it then create that table in destination table using source database

BolChkTable = False
For IntI = 0 To IntTables ' Main Loop

    StrTableName = SourceTables(IntI)

    BolChkTable = False
    dbTableList.MoveFirst
    Do While dbTableList.EOF = False

        If StrTableName = Trim(dbTableList!table_name & "") Then
            BolChkTable = True
            Exit Do
        End If
        dbTableList.MoveNext
        If dbTableList.EOF = True Then Exit Do
    Loop

    If dbTableList.RecordCount > 0 Then
        If BolChkTable = False Then
            Call CreateTable(StrTableName)   ' Create Table

        Else
                ' Check All Fields in Particular table
                ' Take all Fields from Source table and assigned to object that is a field structure

                Set dbFieldList = strcn.OpenSchema(adSchemaColumns, Array(Empty, Empty, StrTableName, Empty))
                IntJ = 0

                ReDim ObjCol(0 To dbFieldList.RecordCount - 1)
                Do While dbFieldList.EOF = False

                    ObjCol(IntJ).FieldName = Trim(dbFieldList!COLUMN_NAME & "")
                    ObjCol(IntJ).FieldType = Trim(columnTypes(dbFieldList!DATA_TYPE) & "")
                    ObjCol(IntJ).CHAR_LENGTH = Val(dbFieldList!CHARACTER_MAXIMUM_LENGTH & "")
                    ObjCol(IntJ).NUM_PRECESION = Val(dbFieldList!NUMERIC_PRECISION & "")
                    ObjCol(IntJ).NUM_SCALE = Val(dbFieldList!NUMERIC_SCALE & "")

                    IntJ = IntJ + 1


                    dbFieldList.MoveNext
                    If dbFieldList.EOF = True Then Exit Do
                Loop
               dbFieldList.Close

               ' Check All Fields in Destination table

               Set dbFieldList = strDcn.OpenSchema(adSchemaColumns, Array(Empty, Empty, StrTableName, Empty))

'               If dbFieldList.RecordCount > 0 Then
'
'               End If


               dbFieldList.MoveFirst
               For IntJ = 0 To UBound(ObjCol) - 1

                    StrColName = ObjCol(IntJ).FieldName
                    BolChkCol = False
                    dbFieldList.MoveFirst
                    Do While dbFieldList.EOF = False

                        If StrColName = dbFieldList!COLUMN_NAME Then
                            BolChkCol = True
                            Exit Do
                        End If
                        dbFieldList.MoveNext
                        If dbFieldList.EOF = True Then Exit Do
                    Loop

                    ' If Field not exist in destination table then Add in that table
                    If BolChkCol = False Then
                        Call AlterTable(ObjCol(IntJ), StrTableName)
                    End If

               Next IntJ
        End If
    End If
Next IntI

End Sub
Public Sub CreateTable(ByVal pStrTableName As String)

On Error GoTo Hell

'Create a Access object
Dim objAccess As Access.Application
Set objAccess = New Access.Application
Dim StrTmp As String

StrSourcePath = "D:\vbwork2\sample\samples.mdb"
StrDestinationPath = "D:\vbwork2\sample\Newsamples.mdb"

'Open the database and run the macro
With objAccess

    StrTmp = strcn.ConnectionString
    strcn.Close
    Set strcn = Nothing
    .Visible = True
    .OpenCurrentDatabase StrSourcePath
    .DoCmd.CopyObject StrDestinationPath, pStrTableName, acTable, pStrTableName
    'Close the Database
    .CloseCurrentDatabase
    strcn.Open StrTmp
End With

Set objAccess = Nothing

Exit_For:
    On Error GoTo 0
    Exit Sub

Hell:
    GoTo Exit_For
End Sub
Private Sub AlterTable(pStrObjCol As ColStruct, ByVal pStrTableName As String)
    Dim StrSql As String

    StrSql = "ALTER TABLE " & pStrTableName
    StrSql = StrSql & " ADD COLUMN " & pStrObjCol.FieldName & " " & pStrObjCol.FieldType & " "

    If pStrObjCol.CHAR_LENGTH > 0 Then
        StrSql = StrSql & "(" & pStrObjCol.CHAR_LENGTH & ")"
    End If

    If pStrObjCol.NUM_PRECESION > 0 Then
        StrSql = StrSql & "[" & pStrObjCol.NUM_PRECESION & ""

        If pStrObjCol.NUM_SCALE > 0 Then
            StrSql = StrSql & "," & pStrObjCol.NUM_SCALE & "]"
        Else
            StrSql = StrSql & ",0]"
        End If
    End If
    strDcn.Execute StrSql

End Sub

Comments

Add New