User:Geoffjw1978/sandbox/paste-cls

Access - create classmodule

clsRemote

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ' ' This code was originally written by Zaid Qureshi (2007). ' It is not to be altered or distributed, ' except as part of an application. ' You are free to use it in any application, ' provided the copyright notice is left unchanged. ' '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Option Explicit Option Compare Database

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private moConn As New ADODB.Connection Private mstrConnString As String Private mblnIsConnected As Boolean

'######### Comment out path depending on Dev or Live ############# Private Const CSTR_PSWD            As String = "tr4nsf0rm3rs"

Private Const CSTR_BACKEND_NAME    As String = "contacts_outlook_export.mdb"  ' "SHARP_be_PROD_v2.0.mdb"  ' MailShot release, reinstate this. Private Const CSTR_BACKEND_PATH    As String = "D:\rsync\rsynced_vaio\todos\auto-mailer"           '   "\\eurfiler4\GBM Risk\RISK RAD\SHARP"

'gt:release: re-instate these 2: 'release: Private Const CSTR_BACKEND_NAME    As String = "SHARP_be.mdb" 'release: Private Const CSTR_BACKEND_PATH    As String = "\\eurfiler4\GBM Risk\RISK RAD\SHARP"

'Private Const CSTR_BACKEND_PATH    As String = "\\Eurfiler4\GBM Risk\RISK RAD\SHARP\UAT Version" 'Private Const CSTR_BACKEND_PATH    As String = "\\eurfiler4\GBM Risk\Risk Solutions & Control\RAD Dev\SHARP\Application\Dev"

Public Function BuildAppendAllSQLString(ByVal strCurrentTable As String, _                                       ByVal strDestinationTable As String) As String ' ' Purpose: Append Update SQL String '   BuildAppendAllSQLString = "INSERT INTO " & strDestinationTable & " SELECT " & strCurrentTable & ".* FROM " & strCurrentTable & ";" End Function

Public Function BuildDeleteAllSQLString(ByVal strTable As String) As String ' ' Purpose: Build Delete SQL String '   BuildDeleteAllSQLString = "DELETE * FROM " & strTable & ";" End Function Public Function GetTableRecordset(ByVal strTable As String) As ADODB.Recordset '-- ' Purpose: Return a recordset of data from a table '--   Dim oRst As New ADODB.Recordset oRst.Open strTable, moConn, adOpenKeyset, adLockOptimistic Set GetTableRecordset = oRst End Function Public Function GetRecordset(ByVal strSQL As String) As ADODB.Recordset '-- ' Purpose: Return a recordset of data from a table '--   Dim oRst As New ADODB.Recordset oRst.CursorLocation = adUseClient oRst.CursorType = adOpenKeyset oRst.LockType = adLockOptimistic oRst.Open strSQL, moConn, adOpenKeyset, adLockOptimistic oRst.ActiveConnection = Nothing Set GetRecordset = oRst Exit Function End Function Public Function ExecuteSQLStatements(ParamArray sSQL As Variant) As Boolean '-- ' Purpose: Executes a series of SQL statements on the database in one batch '--   Dim iIndex As Integer

On Error GoTo Error_Handler: ExecuteSQLStatements = False

moConn.BeginTrans For iIndex = LBound(sSQL) To UBound(sSQL) If Trim(sSQL(iIndex)) <> Empty Then moConn.Execute sSQL(iIndex),, adCmdText End If   Next

moConn.CommitTrans ExecuteSQLStatements = True Exit Function

Error_Handler: moConn.RollbackTrans moConn.Close Set moConn = Nothing ExecuteSQLStatements = False

End Function

Public Function IsConnected As Boolean ' ' Purpose: Close the database '   IsConnected = mblnIsConnected End Function

Private Function OpenDatabase As Boolean ' ' Purpose: Open the database '   OpenDatabase = False mblnIsConnected = False On Error GoTo err_Handler: If (moConn Is Nothing) Or (moConn.State = adStateClosed) Then 'Set moConn = CurrentProject.Connection mstrConnString = CSTR_BACKEND_PATH & "\" & CSTR_BACKEND_NAME moConn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=" & mstrConnString & ";Jet OLEDB:Database Password=" & CSTR_PSWD & ";" mblnIsConnected = True OpenDatabase = True End If   Exit Function err_Handler: OpenDatabase = False Set moConn = Nothing mblnIsConnected = False End Function

Private Function CloseDatabase As Boolean ' ' Purpose: Close the database '   CloseDatabase = False On Error GoTo err_Handler: If (Not moConn Is Nothing) Or (moConn.State = adStateOpen) Then moConn.Close Set moConn = Nothing CloseDatabase = True mblnIsConnected = False End If   Exit Function err_Handler: CloseDatabase = False End Function

Private Sub Class_Initialize '- ' Purpose: open the database when class is invoked '-  Call OpenDatabase End Sub

Private Sub Class_Terminate ' ' Purpose: close the database when class is destroyed '  Call CloseDatabase End Sub

Public Function IsTableAvailable(ByVal strName As String) As Boolean 'Find table 'Create catalog object Dim Catalog As New ADOX.Catalog Set Catalog.ActiveConnection = moConn IsTableAvailable = False On Error GoTo err_Handler:

Dim Table As ADOX.Table For Each Table In Catalog.Tables If strName = Table.Name Then IsTableAvailable = True Exit For End If   Next Set Catalog.ActiveConnection = Nothing Set Catalog = Nothing Exit Function err_Handler: Debug.Print Err.Number & vbTab & Err.Description IsTableAvailable = False End Function

Public Sub ImportTableLocally(ByVal strTable As String) '-- ' Import Table locally '--   Dim strString strString = CSTR_BACKEND_PATH & "\" & CSTR_BACKEND_NAME DoCmd.TransferDatabase acImport, "Microsoft Access", _ strString, acTable, strTable, strTable, True End Sub

Public Function ExecuteSQLLocally(ByVal strSQL As String) As Boolean '-- ' Execute SQL locally '--  On Error GoTo ErrHandler: ExecuteSQLLocally = False DoCmd.RunSQL strSQL ExecuteSQLLocally = True Exit Function ErrHandler: ExecuteSQLLocally = False End Function

Public Function GetRemoteSQLConnectionString As String '-- ' Return the connection string required for executing SQL on a remote db '-- Dim strThisDBPath As String

strThisDBPath = CSTR_BACKEND_PATH & "\" & CSTR_BACKEND_NAME

GetRemoteSQLConnectionString = strThisDBPath

End Function

Public Function ListTablesandQueries As Variant '-- ' Purpose: List tables and queries in database '--   'Create catalog object Dim Catalog        As New ADOX.Catalog Dim intCnt         As Integer Dim Query          As ADOX.Procedure Dim Table          As ADOX.Table Dim Column         As ADOX.Column Dim strArray Set Catalog.ActiveConnection = moConn 'List tables    'gt:todo: restrict list to those tables with queries. intCnt = 0 For Each Table In Catalog.Tables ReDim Preserve strArray(0 To intCnt) strArray(intCnt) = Table.Name intCnt = intCnt + 1 '       Debug.Print Table.Type Next '''   ' gt:todo: check Proceudres has the name we want for our "check if custom or TableDump." '''   For Each Query In Catalog.Procedures '''       ReDim Preserve strArray(0 To intCnt) '''       strArray(intCnt) = Table.Name '''       intCnt = intCnt + 1        Debug.Print Table.Type '''   Next ListTablesandQueries = strArray Set Catalog.ActiveConnection = Nothing Set Catalog = Nothing

End Function

Public Sub AccessWait(ByVal lngMiliSeconds As Long) Call Sleep(lngMiliSeconds) End Sub

Public Function GetRecordsetFromQueryWithParams(ByVal strQueryName As String, ByVal varParams As Variant) As ADODB.Recordset '--- ' Executes an existing query '--- ' MRW - created

Dim iParam         As Integer Dim prmParameter   As ADODB.Parameter Dim objCommand     As ADODB.Command Dim rstOutput      As ADODB.Recordset Set objCommand = New ADODB.Command Set rstOutput = New ADODB.Recordset

Set GetRecordsetFromQueryWithParams = Nothing

On Error GoTo err_Handler With objCommand .ActiveConnection = moConn .CommandType = adCmdStoredProc .CommandText = strQueryName If IsArray(varParams) Then For iParam = 0 To UBound(varParams, 2) - 1 Set prmParameter = objCommand.CreateParameter(varParams(0, iParam), varParams(1, iParam), adParamInput, varParams(2, iParam), varParams(3, iParam)) objCommand.Parameters.Append prmParameter Next iParam End If   objCommand.ActiveConnection.CursorLocation = adUseClient rstOutput.CursorType = adOpenKeyset rstOutput.LockType = adLockOptimistic rstOutput.CursorLocation = adUseClient Set rstOutput = .Execute rstOutput.ActiveConnection = Nothing End With

Set objCommand = Nothing Set GetRecordsetFromQueryWithParams = rstOutput

DoEvents

Exit Function

err_Handler: MsgBox "An error has occurred as follows: " & vbCrLf & _ Err.Number & " " & Err.Description, vbCritical + vbOKOnly, "Unexpected Error"

Set GetRecordsetFromQueryWithParams = Nothing Set objCommand = Nothing

DoEvents

Exit Function

End Function

Public Sub LoadParamArray(ByRef varParams As Variant, _                           ByVal strParamName As String, _                            ByVal dblDataType As Double, _                            ByVal dblDataLength As Double, _                            ByVal varParamValue As Variant)

'- ' Purpose: Builds a variant array of the paramters required by a query '          it does this one parameter per call but persists any '          parameters already loaded - clearing the array is the '          responsibility of the calling routine '- ' MRW - created

Dim intArrayElement        As Integer Dim intArrayBound          As Integer

On Error Resume Next intArrayBound = UBound(varParams, 2) On Error GoTo 0

intArrayElement = intArrayBound intArrayBound = intArrayBound + 1

ReDim Preserve varParams(4, intArrayBound)

varParams(0, intArrayElement) = strParamName varParams(1, intArrayElement) = dblDataType varParams(2, intArrayElement) = dblDataLength varParams(3, intArrayElement) = varParamValue

Exit Sub

End Sub Public Function ExecuteQueryWithParams(ByVal strQueryName As String, ByVal varParams As Variant) As Boolean '- ' Executes an existing query that requires parameter input '- ' MRW - created

Dim iParam         As Integer Dim prmParameter   As ADODB.Parameter Dim objCommand     As ADODB.Command Set objCommand = New ADODB.Command

ExecuteQueryWithParams = False

On Error GoTo err_Handler With objCommand .ActiveConnection = moConn .CommandType = adCmdStoredProc .CommandText = "[" & strQueryName & "]" If IsArray(varParams) Then For iParam = 0 To UBound(varParams, 2) - 1 Set prmParameter = objCommand.CreateParameter(varParams(0, iParam), varParams(1, iParam), adParamInput, varParams(2, iParam), varParams(3, iParam)) objCommand.Parameters.Append prmParameter '           Set prmParameter = Nothing Next iParam End If   .Execute End With

Set objCommand = Nothing ExecuteQueryWithParams = True Exit Function

err_Handler: MsgBox "An error has occurred as follows: " & vbCrLf & _ Err.Number & " " & Err.Description, vbCritical + vbOKOnly, "Unexpected Error"

ExecuteQueryWithParams = False Set objCommand = Nothing

DoEvents

Exit Function

End Function

Public Function ExecuteQuery(ByVal strQueryName As String) As Boolean '--- ' Executes an existing query '--- ' MRW - amended to bracket query name

Dim objCommand As ADODB.Command Set objCommand = New ADODB.Command

ExecuteQuery = False

On Error GoTo err_Handler With objCommand .ActiveConnection = moConn .CommandType = adCmdStoredProc .CommandText = "[" & strQueryName & "]" .Execute End With

Set objCommand = Nothing ExecuteQuery = True

DoEvents

Exit Function

err_Handler:

MsgBox "An error has occurred as follows: " & vbCrLf & _ Err.Number & " " & Err.Description, vbCritical + vbOKOnly, "Unexpected Error"

Call OpenDatabase ExecuteQuery = False Set objCommand = Nothing

DoEvents

Exit Function

End Function

Public Function DeleteTableContents(ByVal strTable As String) As Boolean '-- ' Purpose: Return a recordset of data from a table '-- 'MRW - amended to bracket table name

Dim strSQL As String

DeleteTableContents = False

On Error GoTo err_Handler:

If Left(strTable, 1) <> "[" Then strTable = "[" & strTable & "]" End If strSQL = "DELETE * FROM " & strTable & ";" moConn.Execute strSQL,, adCmdText DeleteTableContents = True

DoEvents

Exit Function err_Handler: DeleteTableContents = False Exit Function

End Function

Public Function CheckQueryExists(strProc As String) As Boolean '-- ' Purpose: Verify if a query exists in database - very strange, ' Author: Geoff Turner '--   'Create catalog object Dim Catalog        As New ADOX.Catalog Dim intCnt         As Integer Dim Query          As ADOX.Procedure Dim View           As ADOX.View Dim Table          As ADOX.Table Dim Column         As ADOX.Column Dim vRes As Variant Dim strArray Set Catalog.ActiveConnection = moConn CheckQueryExists = False For Each Query In Catalog.Procedures If InStr(1, Query.Name, strProc, vbTextCompare) Then CheckQueryExists = True End If   Next Query For Each View In Catalog.Views If InStr(1, View.Name, strProc, vbTextCompare) Then CheckQueryExists = True End If   Next View Set Catalog.ActiveConnection = Nothing Set Catalog = Nothing

End Function