Option Explicit
Public Const gc_strDataBaseName As String = “BrandTrendDatabase.mdb”
Public lngRecEff As Long
Public blnUseVBScript As Boolean
Public g_objConnection As Object
Public g_objRecordSet As Object
Public g_strDBPath As String
Public Enum QrySchema
QrySchemaProcedures = 16
QrySchemaTables = 20
QrySchemaViews = 23
End Enum
Function GetDBPath() As String
‘GetDBPath = g_strDBPath & Application.PathSeparator & gc_strDataBaseName
‘GetDBPath = Environ(“temp”) & “\BSN_Temp\” & gc_strDataBaseName
GetDBPath = ThisWorkbook.Path & Application.PathSeparator & gc_strDataBaseName
‘GetDBPath = ThisWorkbook.CustomDocumentProperties(“DatabasePath”).Value
‘GetDBPath = “Z:\Graham_BT\Business Intelligence – Europe\P – 20017 Italy Sales report\WIP\SalesPerformanceDB – Copy.mdb”
End Function
Function blnConnectDatabase(strPath As String, strDBPass As String) As Boolean
Set g_objConnection = CreateObject(“ADODB.Connection”)
On Error GoTo ErrH
g_objConnection.Open “Provider=Microsoft.Jet.OLEDB.4.0; Data Source=” & _
strPath & “;Jet OLEDB:Database Password=” & strDBPass & “;”
On Error GoTo 0
blnConnectDatabase = True
GoTo ExitH
ErrH:
blnConnectDatabase = False
Set g_objConnection = Nothing
ExitH:
Application.StatusBar = False
End Function
Function blnTableExistsInDB(strTableName As String) As Boolean
Dim rst As Object
Dim strTbl As String
strTbl = strTableName
Call blnConnectDB
Set rst = CreateObject(“ADODB.Recordset”)
Set rst = g_objConnection.OpenSchema(20) ‘adSchemaTables
If Left(strTbl, 1) = “[” And Right(strTbl, 1) = “]” Then
strTbl = Mid(strTbl, 2, Len(strTbl) – 2)
End If
rst.Filter = “TABLE_TYPE=’TABLE’ and TABLE_NAME='” & strTbl & “‘”
On Error Resume Next
blnTableExistsInDB = (UCase(rst.fields(“TABLE_NAME”).Value) = UCase(strTbl))
On Error GoTo 0
If Err.Number <> 0 Then blnTableExistsInDB = False
Set rst = Nothing
End Function
Function blnFieldExistsInTable(ByVal strTableName As String, ByVal strFieldName As String) As Boolean
Dim rst As Object
Dim strTbl As String
strTbl = strTableName
Call blnConnectDB
Set rst = CreateObject(“ADODB.Recordset”)
Set rst = g_objConnection.OpenSchema(4) ‘adSchemaColumns
If Left(strTbl, 1) = “[” And Right(strTbl, 1) = “]” Then
strTbl = Mid(strTbl, 2, Len(strTbl) – 2)
End If
rst.Filter = “TABLE_NAME = ‘” & strTableName & “‘ and COLUMN_NAME='” & strFieldName & “‘”
On Error Resume Next
blnFieldExistsInTable = (UCase(rst.fields(“COLUMN_NAME”).Value) = UCase(strFieldName))
On Error GoTo 0
If Err.Number <> 0 Then blnFieldExistsInTable = False
Set rst = Nothing
End Function
Function blnProcExistsInDB(strProcName As String) As Boolean
Dim rst As Object
Dim strProc As String
strProc = strProcName
Call blnConnectDB
Set rst = CreateObject(“ADODB.Recordset”)
Set rst = g_objConnection.OpenSchema(16) ‘adSchemaProcedures
If Left(strProc, 1) = “[” And Right(strProc, 1) = “]” Then
strProc = Mid(strProc, 2, Len(strProc) – 2)
End If
rst.Filter = “PROCEDURE_NAME='” & strProc & “‘”
On Error Resume Next
blnProcExistsInDB = (UCase(rst.fields(“PROCEDURE_NAME”).Value) = UCase(strProc))
On Error GoTo 0
If Err.Number <> 0 Then blnProcExistsInDB = False
Set rst = Nothing
End Function
Sub ExecuteDBQuery(strQuery As String, Optional rngTarget As Range, Optional blnHeader As Boolean, Optional blnClient As Boolean = False)
Dim intColIndex As Integer
Dim lngRowOffset As Long
‘On Error GoTo ErrH
Call blnConnectDB
Set g_objRecordSet = Nothing
Set g_objRecordSet = OpenRecordSet(strQuery, blnClient)
DoEvents
If g_objRecordSet Is Nothing Then Exit Sub
With g_objRecordSet
If Not rngTarget Is Nothing Then
Set rngTarget = rngTarget.Cells(1, 1)
End If
If Not rngTarget Is Nothing Then
If blnHeader = True Then
For intColIndex = 0 To .fields.Count – 1 ‘field names
rngTarget.Cells(1, intColIndex + 1).NumberFormat = “@”
rngTarget.Cells(1, intColIndex + 1).Value = .fields(intColIndex).Name
rngTarget.Cells(1, intColIndex + 1).Font.Bold = True
Next intColIndex
lngRowOffset = 1
Else ‘Without field names
lngRowOffset = 0
End If
If Application.Version < 12 And .RecordCount + rngTarget.Cells(lngRowOffset + 1, 1).Row > 65535 Then
MsgBox “Records upto row number 65535 can be accommodated. Rest will be ignored.”, vbInformation, “Database”
ElseIf Application.Version >= 12 And .RecordCount + rngTarget.Cells(lngRowOffset + 1, 1).Row > 1048576 Then
MsgBox “Records upto row number 1048576 can be accommodated. Rest will be ignored.”, vbInformation, “Database”
End If
rngTarget.Cells(lngRowOffset + 1, 1).CopyFromRecordset g_objRecordSet ‘ the recordset data
End If
End With
ErrH:
If Err.Number <> 0 Then
‘MsgBox Err.Description, vbCritical, “Error”
‘MsgBox “Database Query Error”
End If
End Sub
Sub DropTable(ParamArray strTableName() As Variant)
Dim x As Integer
For x = LBound(strTableName) To UBound(strTableName)
If blnTableExistsInDB(CStr(strTableName(x))) = True Then
Call ExecuteDBQuery(“Drop Table [” & Replace(Replace(CStr(strTableName(x)), “[“, “”), “]”, “”) & “]”)
End If
Next x
End Sub
Sub DropField(ByVal strTblName As String, ParamArray strColumnName() As Variant)
Dim x As Integer
For x = LBound(strColumnName) To UBound(strColumnName)
If blnFieldExistsInTable(strTblName, CStr(strColumnName(x))) = True Then
Call ExecuteDBQuery(“ALTER TABLE [” & Replace(Replace(CStr(strTblName), “[“, “”), “]”, “”) & “] DROP COLUMN [” & strColumnName(x) & “]”)
End If
Next x
End Sub
Sub DropProcedure(ParamArray strProcName() As Variant)
Dim x As Integer
For x = LBound(strProcName) To UBound(strProcName)
If blnProcExistsInDB(CStr(strProcName(x))) = True Then
Call ExecuteDBQuery(“Drop PROCEDURE [” & CStr(strProcName(x)) & “]”)
End If
Next x
End Sub
Function blnConnectDB() As Boolean
Dim blnCon As Boolean
blnCon = True
If g_objConnection Is Nothing Then
blnCon = blnConnectDatabase(GetDBPath, “gskbt”)
ElseIf Not g_objConnection.State = 1 Then
blnCon = blnConnectDatabase(GetDBPath, “gskbt”)
End If
blnConnectDB = blnCon
End Function
Sub CompactDB()
Dim strRes As String
Application.StatusBar = “Compacting database…”
strRes = DatabaseCompact(GetDBPath)
If strRes = vbNullString Then
‘MsgBox “Succeeded in compacting database …”, vbInformation
Application.StatusBar = “Succeeded in compacting database …”
Else
‘MsgBox strRes & ” Unable to clean database …”
Application.StatusBar = strRes & ” Unable to clean database …”
End If
End Sub
Function DatabaseCompact(strDBPath As String, Optional strDBPass As String = “”) As String
On Error GoTo ErrFailed
‘Delete the existing temp database
If Len(Dir$(strDBPath & “.tmp”)) Then
VBA.Kill strDBPath & “.tmp”
End If
CloseDB
With CreateObject(“JRO.JetEngine”)
If strDBPass = “” Then ‘DB without password
.CompactDatabase “Provider=Microsoft.Jet.OLEDB.4.0;Data Source=” & strDBPath, “Provider=Microsoft.Jet.OLEDB.4.0;Data Source=” & strDBPath & “.tmp;Jet OLEDB:Encrypt Database=True”
Else ‘Password protected db
.CompactDatabase “Provider=Microsoft.Jet.OLEDB.4.0;Data Source=” & strDBPath & “;Jet OLEDB:Database Password=” & strDBPass, “Provider=Microsoft.Jet.OLEDB.4.0;Data Source=” & strDBPath & “.tmp;Jet OLEDB:Encrypt Database=True;Jet OLEDB:Database Password=” & strDBPass
End If
End With
On Error GoTo 0
VBA.Kill strDBPath ‘Delete the existing database
Name strDBPath & “.tmp” As strDBPath ‘Rename the compacted database
ErrFailed:
If Err.Number <> 0 Then
DatabaseCompact = Err.Description
Else
DatabaseCompact = vbNullString
End If
End Function
Function SetRecordSet(Optional blnClient As Boolean = False) As Object
Dim objg_objRecordSet As Object
Set objg_objRecordSet = CreateObject(“ADODB.Recordset”)
With objg_objRecordSet
If blnClient = True Then
.CursorLocation = 3 ‘adUseClient
End If
End With
Set SetRecordSet = objg_objRecordSet
Set objg_objRecordSet = Nothing
End Function
Public Function OpenRecordSet(ByVal strSql As String, Optional blnClient As Boolean = False) As Object
Dim objg_objRecordSet As Object
Dim bolRecordset As Boolean
Set objg_objRecordSet = Nothing
If Not LCase(strSql) Like “update*” And Not LCase(strSql) Like “delete*” And _
Not LCase(strSql) Like “alter*” And Not LCase(strSql) Like “drop*” And _
Not LCase(strSql) Like “create*” And Not LCase(strSql) Like “* into *” And _
Not LCase(strSql) Like “insert*” Then
bolRecordset = True
Else
bolRecordset = False
End If
If bolRecordset Then
Set objg_objRecordSet = CreateObject(“ADODB.Recordset”)
With objg_objRecordSet
If blnClient = True Then
.CursorLocation = 3 ‘adUseClient
‘.Open strSQL, g_objConnection, adOpenForwardOnly, adLockReadOnly, adCmdText
.Open strSql, g_objConnection, 0, 1, 1
If .RecordCount <> 0 Then .movefirst
.ActiveConnection = Nothing
Else
‘.Open strSQL, g_objConnection, adOpenStatic, adLockOptimistic, adCmdText
.Open strSql, g_objConnection, 3, 3, 1
If objg_objRecordSet.State = 1 Then
If .EOF = False And .BOF = False Then .movefirst
End If
End If
End With
Set OpenRecordSet = objg_objRecordSet
Else
g_objConnection.Execute strSql, lngRecEff
End If
Set objg_objRecordSet = Nothing
bolRecordset = Empty
End Function
Sub CloseDB()
On Error Resume Next
g_objConnection.Close
‘
On Error GoTo 0
If Not g_objConnection Is Nothing Then
If g_objConnection.State = 1 Then g_objConnection.Close
End If
‘ If Not g_objRecordSet Is Nothing Then
‘ If g_objRecordSet.State = 1 Then
‘ End If
Set g_objConnection = Nothing
‘Set g_objRecordSet = Nothing
End Sub
Function ChangeColumnName(ByVal strDBFullPath As String, ByVal strTabName As String, _
ByVal strOldColName As String, ByVal strNewColName As String) As Boolean
Dim objCat As Object
Dim objTbl As Object
Const strMsgBoxTitle As String = “Change Column Name”
On Error GoTo XitPoint
Set objCat = CreateObject(“ADOX.Catalog”)
Set objTbl = CreateObject(“ADOX.Table”)
objCat.ActiveConnection = “Provider=Microsoft.Jet.OLEDB.4.0;Data Source= ” & strDBFullPath
Set objTbl = objCat.Tables(strTabName)
objTbl.Columns(strOldColName).Name = strNewColName
objCat.ActiveConnection.Close
ChangeColumnName = True
Exit Function
XitPoint:
If Err.Number = 3265 Then
MsgBox “Given table\column is not found. Please check if the given table\column exist.”, vbCritical, strMsgBoxTitle
ElseIf Err.Number <> 3265 And Err.Number <> 0 Then
MsgBox “Error Number:- ” & Err.Number & vbLf & “Error Description:- ” & Err.Description, vbCritical, strMsgBoxTitle
End If
Err.Clear
On Error GoTo 0
ChangeColumnName = False
End Function
Sub ModifyQryDef(ByVal strQryName As String, ByVal strNewQryDef As String, _
ByVal strRplwhat As String, ByVal strRplwith As String, _
ByVal QrySchemaType As QrySchema, Optional blnReplace As Boolean = False)
Dim objCmd As Object
Dim objCat As Object
Dim objCmdType As Object
On Error GoTo XitPoint
‘Checking for db connection
Call blnConnectDB
‘Creating ADOX Object
Set objCat = CreateObject(“ADOX.Catalog”)
Set objCat.ActiveConnection = g_objConnection
‘Checking query type
Select Case QrySchemaType
Case 16 ‘Procedures
Set objCmdType = objCat.Procedures(strQryName)
Case 20 ‘Tables
Set objCmdType = objCat.Tables(strQryName)
Case 23 ‘Views
Set objCmdType = objCat.Views(strQryName)
End Select
‘Getting commond object
Set objCmd = objCmdType.Command
‘If need to replace query
If blnReplace Then
strNewQryDef = objCmd.CommandText
strNewQryDef = Replace(strNewQryDef, strRplwhat, strRplwith)
End If
‘Modifying query
objCmd.CommandText = strNewQryDef
Set objCmdType.Command = objCmd
XitPoint:
If Err.Number <> 0 Then
MsgBox “Err. Number:- ” & Err.Number & vbLf & vbLf & “Err. Description:- ” & Err.Description, vbCritical, “Database”
Err.Clear
On Error GoTo 0
End If
Set objCmdType = Nothing
Set objCmd = Nothing
Set objCat = Nothing
End Sub
Sub CreateProcedure(ByVal strProName As String, ByVal strQry As String, Optional blnShowErrMsg As Boolean = False)
Dim objCmd As Object
Dim objCat As Object
On Error GoTo XitPoint
‘Checking for db connection
Call blnConnectDB
‘Creating ADOX Object
Set objCat = CreateObject(“ADOX.Catalog”)
Set objCat.ActiveConnection = g_objConnection
‘Getting commond object
Set objCmd = CreateObject(“ADODB.Command”)
‘Modifying query
objCmd.CommandText = strQry
objCat.Views.Append strProName, objCmd
XitPoint:
If Err.Number <> 0 Then
If blnShowErrMsg Then
MsgBox “Err. Number:- ” & Err.Number & vbLf & vbLf & “Err. Description:- ” & Err.Description, vbCritical, “Database”
End If
Err.Clear
On Error GoTo 0
End If
Set objCmd = Nothing
Set objCat = Nothing
End Sub
Power Desk 