Source code for Issue Number 89

Copyright 1997-2000 by C&D Programming Corp. All Rights Reserved. Source code may not be reproduced except for use in a compiled executable. All rights reserved. If you would like to reprint any or all of this code please email us at info@codeoftheweek.com

Code of the Week Home

Source Code

Just paste this code into any class and change the name of the class to cJetReplication.

'----------------------------------------------------------------------
'
'   Module Name:    cJetReplication
'   Written By:     C&D Programming Corp.
'   Create Date:    3/99
'   Copyright:      Copyright 1998-99 by C&D Programming Corp.  Source
'                   code may not be reproduced except for use in a
'                   compiled executable.  All rights reserved.  If
'                   you would like to reprint any or all of this
'                   code please email us at info@codeoftheweek.com
'
'
'----------------------------------------------------------------------
Option Explicit

Public TableName As String
Public ExclusiveMode As Boolean ' how the database will be opened.
Public ReplicaName As String

Private msDatabaseName As String
Private mDB As Database

Public Property Let DatabaseName(sDatabaseName As String)
    If msDatabaseName <> "" Then
        CloseDatabase
    End If
    msDatabaseName = Trim(sDatabaseName)
    If msDatabaseName <> "" Then
        OpenDatabase
    End If
End Property

Public Property Get DatabaseName() As String
    DatabaseName = msDatabaseName
End Property

Public Sub OpenDatabase()
    Set mDB = DBEngine.OpenDatabase(msDatabaseName, ExclusiveMode)
End Sub

Public Sub CloseDatabase()
    mDB.Close
End Sub

Public Sub MakeDesignMaster()
    Dim db As Database
    Dim prpNew As Property
    Dim bReOpen As Boolean

    ' The database needs to be open exclusively to make it into a
    ' design master.
    bReOpen = False
    If Not ExclusiveMode Then
        CloseDatabase
        ExclusiveMode = True
        OpenDatabase
        bReOpen = True
    End If

    With mDB
        ' If Replicable property doesn't exist, create it.
        ' Turn off error handling in case property exists.
        On Error Resume Next
        Set prpNew = .CreateProperty("Replicable", dbText, "T")
        .Properties.Append prpNew
        Err.Clear
        On Error GoTo 0

        ' Set database Replicable property to True.
        .Properties("Replicable") = "T"
    End With

    If bReOpen Then
        ' force database to be reopened in shared mode
        CloseDatabase
        ExclusiveMode = False
        OpenDatabase
    End If
    Exit Sub

Handler:
    Err.Raise Err.Number, "MakeDesignMaster", Err.Description
End Sub

Public Sub Synchronize()
    ' If you need to fine-tune this synchronization method you can using the below
    ' parameters to the synchronize method:
    '   dbRepExportChanges  Sends changes from database to pathname.
    '   dbRepImportChanges  Sends changes from pathname to database.
    '   dbRepImpExpChanges  (Default) Sends changes from database to pathname, and vice-versa, also known as bidirectional exchange.
    '   dbRepSyncInternet   Exchanges data between files connected by an Internet pathway.
    mDB.Synchronize ReplicaName
End Sub

Private Sub MakeReplica(Optional sReplicaDescription As String = "", Optional lOptions As ReplicaTypeEnum)
    On Error GoTo Handler
    If sReplicaDescription = "" Then
        sReplicaDescription = "Replica of " & DatabaseName
    End If
    mDB.MakeReplica ReplicaName, sReplicaDescription, lOptions
    Exit Sub

Handler:
    Err.Raise Err.Number, "MakeReplica", Err.Description
End Sub

Public Sub MakeTableReplicable()
    Dim db As Database
    Dim tdfTable As TableDef

    On Error GoTo Handler
    Set tdfTable = mDB.TableDefs(TableName)
    SetReplicable tdfTable
    Exit Sub

Handler:
    Err.Raise Err.Number, "MakeTableReplicable", Err.Description
End Sub

Public Sub MakeTableLocal()
    Dim db As Database
    Dim tdfTable As TableDef

    On Error GoTo Handler
    Set tdfTable = mDB.TableDefs(TableName)
    ResetReplicable tdfTable
    Exit Sub

Handler:
    Err.Raise Err.Number, "MakeTableReplicable", Err.Description
End Sub

Private Sub SetReplicable(tdfTemp As TableDef)

    On Error GoTo ErrHandler
    tdfTemp.Properties("Replicable") = "T"
    On Error GoTo 0
    Exit Sub

ErrHandler:

    Dim prpNew As Property
    ' could not find property so create it.
    If Err.Number = 3270 Then
        Set prpNew = tdfTemp.CreateProperty("Replicable", dbText, "T")
        tdfTemp.Properties.Append prpNew
    Else
        Err.Raise Err.Number, "SetReplicable", Err.Description
    End If
End Sub

Private Sub ResetReplicable(tdfTemp As TableDef)

    On Error GoTo ErrHandler
    tdfTemp.Properties("Replicable") = "F"
    On Error GoTo 0
    Exit Sub

ErrHandler:
    Err.Raise Err.Number, "ResetReplicable", Err.Description
End Sub

Public Sub MakeFullReplica(Optional sReplicaDescription As String = "")
    MakeReplica sReplicaDescription, 0
End Sub

Public Sub MakeFullReadOnlyReplica(Optional sReplicaDescription As String = "")
    MakeReplica sReplicaDescription, dbRepMakeReadOnly
End Sub

Private Sub Class_Initialize()
    ExclusiveMode = False
End Sub

Private Sub Class_Terminate()
    If DatabaseName <> "" Then
        CloseDatabase
    End If
End Sub