Cacher is the code snippet organizer for pro developers

Option Compare Database
Option Explicit




Public Sub ReplicateTableFromServerDownToClient(strTableName As String, cn As ADODB.Connection, blnRetrieveArchive As Boolean)
    
    On Error GoTo errUnableToReplicateToClient
    
    '// Define a query which will retrieve all rows from the server database table
    Set rsServer = New ADODB.Recordset
    Set rsClient = New ADODB.Recordset
    If strTableName = "tblTechnicalLog" And blnRetrieveArchive = False Then
        strLookup = DLookup("[StatusID]", "tblStatus", "[StatusName]=" & Chr(39) & "Open" & Chr(39))
        strSQL = "SELECT * FROM tblTechnicalLog WHERE StatusID = " & Chr(39) & strLookup & Chr(39)
    ElseIf strTableName = "tblXrefLogManager" And blnRetrieveArchive = False Then
        strSQL = "SELECT t1.TechnicalLogID, t1.TechManagerID, t1.LeadTechManager " & _
                    "FROM tblXrefLogManager AS t1, tblTechnicalLog AS t2, tblStatus AS t3 " & _
                    "WHERE t1.TechnicalLogID = t2.TechnicalLogID AND t2.StatusID = t3.StatusID AND t3.StatusName = 'Open'"
    Else
        strSQL = "SELECT * FROM " & strTableName
    End If
    rsServer.Open strSQL, cn, adOpenStatic, adLockOptimistic '// adOpenDynamic
    rsClient.Open strSQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
  
    '// Identify how many rows are in the server database table
    If rsServer.EOF = False Then
        rsServer.MoveLast
        lngNumberOfRows = rsServer.RecordCount
        rsServer.MoveFirst
    End If
  
    '// Dont attempt to replicate if the table is empty
    If lngNumberOfRows = 0 Then
        GoTo skipProcessing
    End If
  
    '// Empty the table on the client database
    DoCmd.SetWarnings False
    DoCmd.RunSQL ("DELETE FROM " & strTableName)
    DoCmd.SetWarnings True
    
    '// START : loop around all rows in the server database table
    For lngRowNumber = 0 To (lngNumberOfRows - 1)

    '// Create an empty row - later used to insert into the client database table
    rsClient.AddNew
  
    '// START : loop around all columns in the current row from the server database table
    For lngColumnNumber = 0 To (rsServer.Fields.Count - 1)
  
    '// Fill the column in the client database table with the contents of the column
    '// In the server database table
    If IsNull(rsServer.Fields(lngColumnNumber)) = False Then
        rsClient.Fields(lngColumnNumber) = rsServer.Fields(lngColumnNumber)
    End If
  
    '// END : loop around all columns in the current row from the server database table
    Next lngColumnNumber
  
    '// Insert the formatted row into the client database table
    rsClient.Update

    '// Get the next row from the server database table
    rsServer.MoveNext
  
    '// END : loop around all rows in the server database table
    Next lngRowNumber
    
    rsServer.Close
    rsClient.Close
    Set rsServer = Nothing
    Set rsClient = Nothing

Exit Sub

skipProcessing:

    '// Close recordsets
    Set rsClient = Nothing
    Set rsServer = Nothing
    cn.Close
    Set cn = Nothing
    
    Exit Sub
    
errUnableToReplicateToClient:

    MsgBox "Unexpected Error : " & Err.Number & vbNewLine & Err.description
    GoTo skipProcessing
    
End Sub




Public Sub ReplicateRowFromClientUpToServerDB(strTableName As String, strNameValuePair As Variant, cn As ADODB.Connection)
        
    '// Determine whether a row already exists with this primary key in the server database
    Set rsServer = New ADODB.Recordset
              
    '// Build SQL Statement
    strSQL = "SELECT * FROM " & strTableName
            
    For i = 0 To UBound(strNameValuePair)
    
    If strNameValuePair(i, 1) = "True" Or strNameValuePair(i, 1) = "False" Then
        '// Do nothing
    Else
        strNameValuePair(i, 1) = Chr(39) & strNameValuePair(i, 1) & Chr(39)
    End If
    
        If i = 0 Then
            strSQL = strSQL & " WHERE " & _
                                strNameValuePair(i, 0) & " = " & strNameValuePair(i, 1)
        Else
            strSQL = strSQL & " AND " & _
                                strNameValuePair(i, 0) & " = " & strNameValuePair(i, 1)
        
        End If
        
    Next i
            
    rsServer.Open strSQL, cn, adOpenDynamic, adLockOptimistic
    If rsServer.EOF = True Then
        blnRowAlreadyExists = False
    ElseIf rsServer.EOF = False And strTableName = "tblXrefLogManager" Then
        '// Delete related xref details
        strSQL = "DELETE * FROM " & strTableName & " WHERE TechnicalLogID = " & strNameValuePair(0, 1)
        cn.Execute strSQL
        blnRowAlreadyExists = False
    ElseIf strTableName = "tblXrefManagerTeam" Then
        '// Delete related xref details
        strSQL = "DELETE * FROM " & strTableName & " WHERE TechnicalLogID = " & strNameValuePair(2, 1)
        cn.Execute strSQL
        blnRowAlreadyExists = False
    Else
        blnRowAlreadyExists = True
    End If
    rsServer.Close
    Set rsServer = Nothing
  
    '// Build SQL Statement
    strSQL = "SELECT * FROM " & strTableName
            
    For i = 0 To UBound(strNameValuePair)
    
        If i = 0 Then
            strSQL = strSQL & " WHERE " & _
                                strNameValuePair(i, 0) & " = " & strNameValuePair(i, 1)
        Else
            strSQL = strSQL & " AND " & _
                                strNameValuePair(i, 0) & " = " & strNameValuePair(i, 1)
        
        End If
        
    Next i
    
    '// Open client database
    Set rsClient = New ADODB.Recordset
    rsClient.Open strSQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
    '// Open server database
    Set rsServer = New ADODB.Recordset
    If blnRowAlreadyExists = True Then

        '// Build SQL Statement
        strSQL = "SELECT * FROM " & strTableName
                
        For i = 0 To UBound(strNameValuePair)
            
            If i = 0 Then
                strSQL = strSQL & " WHERE " & _
                                    strNameValuePair(i, 0) & " = " & strNameValuePair(i, 1)
            Else
                strSQL = strSQL & " AND " & _
                                    strNameValuePair(i, 0) & " = " & strNameValuePair(i, 1)
            
            End If
            
        Next i
        rsServer.Open strSQL, cn, adOpenDynamic, adLockOptimistic
    
    Else
        strSQL = "SELECT * FROM " & strTableName
        rsServer.Open strSQL, cn, adOpenDynamic, adLockOptimistic
    End If
        
    '// If the row doesn't already exists then create a new record in the recordset
    If blnRowAlreadyExists = False Then
        rsServer.AddNew
    End If
        
    '// Format all of the columns in the row
    For lngColumn = 0 To (rsClient.Fields.Count - 1)
        rsServer.Fields(lngColumn) = rsClient.Fields(lngColumn)
    Next lngColumn
       
    '// Insert/update the row into the server database table
    rsServer.Update
    
    '// Close the client database
    rsClient.Close
    Set rsClient = Nothing
    
    '// Close the server database
    rsServer.Close
    Set rsServer = Nothing
    
End Sub