Access Data Projects Utilities

Version Compatibility: Visual Basic 6

More information: Various utilities for Access Data Projects. For use within Access.

Instructions: Copy the declarations and code below and paste directly into your VB project.

[code]Public publRptName As String
Public publFrmName As String
Public boolResume As Boolean
Public boolResumeNext As Boolean

' you need to create SP named 'AppendAppActivity (for logging actions)

Option Compare Database
Option Explicit

Public Sub OpenAccessForm(frmName As String)
'this is used to open a form
'instead of using docmd.open form in each spot; use this in order to centralize errhandling
On Error GoTo errhandler
publRptName = ""
publFrmName = frmName
DoCmd.OpenForm frmName
cleanexit:
Exit Sub
FrmError:
'Centralized spell-checking of form-names here??
'That way if someone accidently spells calendar wrong, it will still be able to find the form
DoCmd.OpenForm frmName, acDesign
GoTo cleanexit
errhandler:
MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Resume FrmError
End Sub

Public Sub OpenAccessReport(rptName As String)
'use this to export reports to SNP by default.
'additionally, you can use this to handle for certain user conditions; etc
publRptName = rptName
publFrmName = ""
On Error Resume Next
Kill "C:\" & rptName & ".snp"
On Error GoTo OpenNormalView

'If GetUserName = "administrator" Then GoTo OpenNormalView
'This line will transfer the report to SNAPSHOT (so they can keep the report open w/o Access)
DoCmd.OutputTo acOutputReport, rptName, acFormatSNP, "C:\" & rptName & ".snp", True

cleanexit:
Exit Sub

OpenNormalView:
On Error GoTo errhandler
DoCmd.OpenReport rptName, acViewPreview
GoTo cleanexit
OpenPrintView:
On Error GoTo errhandler
DoCmd.OpenReport rptName, acViewNormal
GoTo cleanexit
errhandler:
DoCmd.OpenReport rptName, acViewDesign
GoTo cleanexit
End Sub

Public Sub EnterProc(procModuleAndName)
'Log AppActivity
On Error GoTo errhandler
DoCmd.RunSQL "EXEC spAppendAppActivity 1, " & Chr(34) & procModuleAndName & Chr(34)
cleanexit:
Exit Sub
errhandler:
Call errhandler(Err.Number, Err.Description, "basGlobalDbFunctions.EnterProc")
Resume Next

End Sub

Public Sub errhandler(ErrNumber As Integer, ErrDescription As String, strLocation As String)
On Error GoTo errhandler
boolResume = False
boolResumeNext = False
Dim strSql As String
Dim msg As String
Dim msgResult As String
strSql = "EXEC spAppendErr " & ErrNumber & ", " & Chr(34) & ErrDescription & Chr(34) & ", " & Chr(34) & strLocation & Chr(34)
DoCmd.RunSQL strSql, True
If Right(strLocation, 14) = "TestAllReports" Then
GoTo cleanexit
GoTo cleanexit
End If
Select Case ErrNumber
Case 0
GoTo cleanexit
Case 20
GoTo cleanexit
Case 3 'Missing Delimiter
GoTo cleanexit
Case 2812
If bool2812 = 1 Then GoTo cleanexit
MsgBox "It appears that you have the wrong version of the SQL Server database." & vbCrLf & "Please contact Aaron_kempf@hotmail.com", vbOKOnly
bool2812 = 1
GoTo cleanexit
Case 2580
On Error Resume Next
DoCmd.OpenForm publFrmName, acDesign
DoCmd.OpenReport publRptName, acDesign
GoTo cleanexit
Case Else
End Select
msg = "We have encountered an error. Would you like to continue?" & vbCrLf & _
"Err.Number: " & ErrNumber & vbCrLf & _
"Err.Description: " & ErrDescription
TryAgain:
msgResult = MsgBox(msg, vbYesNo + vbCritical)

If msgResult = vbYes Then
GoTo cleanexit
ElseIf msgResult = vbNo Then
End
GoTo cleanexit
Else
Resume TryAgain
End If
cleanexit:
Exit Sub
errhandler:
' MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Resume Next
End Sub

Public Sub TestAllReports()
On Error GoTo errhandler
Dim rpt As AccessObject
Dim errCount As Integer
For Each rpt In CurrentProject.AllReports

DoCmd.RunSQL "EXEC spAppendAppActivity 2, 'OpenRpt: " & rpt.Name & "'", True

Call TestOneReport(rpt)
Next rpt
cleanexit:
Exit Sub
errhandler:
MsgBox Error$, vbOKOnly
Resume
GoTo cleanexit
End Sub

Public Sub TestAllForms()
On Error GoTo errhandler
Dim frm As AccessObject
For Each frm In CurrentProject.AllForms
DoCmd.RunSQL "EXEC spAppendAppActivity 2, 'OpenFrm: " & frm.Name & "'", True
Call TestOneForm(frm)
nextFrm:
Next frm
cleanexit:
Exit Sub
errhandler:
MsgBox Error$, vbOKOnly
Resume nextFrm
GoTo cleanexit
End Sub

Public Sub TestOneReport(rpt As AccessObject)
On Error GoTo cleanexit
DoCmd.OpenReport rpt.Name, acViewDesign
DoCmd.OpenReport rpt.Name, acPreview
'DoCmd.OutputTo acOutputReport, rpt.Name, acFormatSNP, "C:\" & rpt.Name & ".snp", False
DoCmd.Close acReport, rpt.Name, acSaveYes
cleanexit:
Exit Sub
End Sub

Public Sub TestOneForm(frm As AccessObject)
On Error GoTo errhandler
Dim testfrmRst As New ADODB.Recordset

DoCmd.OpenForm frm.Name, acViewDesign
DoCmd.OpenForm frm.Name, acNormal

Dim tempRs As String
tempRs = Forms(frm.Name).Form.RecordSource



If Left(tempRs, 4) = "view" Then testfrmRst.Open "Select " & tempRs & ".* FROM " & tempRs, CurrentProject.Connection
If Left(tempRs, 2) = "sp" Then testfrmRst.Open "EXEC " & tempRs, CurrentProject.Connection


DoCmd.Close acForm, frm.Name, acSavePrompt


cleanexit:
On Error Resume Next
Set testfrmRst = Nothing

Exit Sub
errhandler:
DoCmd.OpenForm frm.Name, acDesign
GoTo cleanexit
End Sub

Public Sub OpenActionQuery(qryName As String)
On Error GoTo errhandler
DoCmd.RunSQL "EXEC spAppendAppActivity 2, 'OpenQry: " & qryName & "'", True
Dim qry As AccessObject
Dim exists As Boolean
For Each qry In CurrentData.AllQueries
If qry.Name = qryName Then
GoTo OpenQuery
End If
NextQry:
Next qry
Debug.Print qryName
MsgBox "Query not found: " & qryName, vbOKOnly
Stop
GoTo cleanexit
OpenQuery:
' DoCmd.OpenQuery qryName
DoCmd.RunSQL "EXEC " & qryName, True
cleanexit:
Exit Sub
errhandler:
Call errhandler(Err.Number, Err.Description, "basGlobalDbFunctions.OpenActionQuery")
If boolResume = True Then Resume
If boolResumeNext = True Then Resume Next
GoTo cleanexit
End Sub

Public Sub OpenApplication()
DoCmd.Close acForm, "frmLOGON", acSavePrompt
OpenAccessForm "Projects"
End Sub

Public Sub TruncateAllTables()
On Error GoTo errhandler

Dim tbl As AccessObject

For Each tbl In CurrentData.AllTables

If LCase(Left(tbl.Name, 3)) = "sys" Then GoTo nextTbl
DoCmd.RunSQL "TRuncate table [" & tbl.Name & "]", True

nextTbl:
Next tbl

cleanexit:
Exit Sub

errhandler:
'MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Dim newSql As String
'DELETE FROM dbo.tblCostbook
newSql = "Delete FROM [" & tbl.Name & "]"
DoCmd.RunSQL newSql

Resume nextTbl
GoTo cleanexit

End Sub

Public Sub RebuildAutoDe()
On Error GoTo errhandler

Dim tbl As AccessObject
Dim strSql As String

For Each tbl In CurrentData.AllTables

If LCase(Left(tbl.Name, 3)) = "sys" Then GoTo nextTbl


On Error GoTo errDropConstraint
'drop the constraint
strSql = Replace("ALTER TABLE dbo.tblAdjustment DROP CONSTRAINT DF_tblAdjustment_autoDE", "tblAdjustment", tbl.Name)
DoCmd.RunSQL strSql

SkipDropConstraint:
On Error GoTo errDropColumn
'drop the column
strSql = Replace("ALTER TABLE dbo.tblAdjustment DROP COLUMN autoDE", "tblAdjustment", tbl.Name)
DoCmd.RunSQL strSql
SkipDropColumn:
On Error GoTo errhandler
'add the column
strSql = Replace("ALTER TABLE dbo.tblAdjustment ADD autoDE datetime NULL", "tblAdjustment", tbl.Name)
DoCmd.RunSQL strSql
'add the constraint
strSql = Replace("ALTER TABLE dbo.tblAdjustment ADD CONSTRAINT DF_tblAdjustment_autoDE DEFAULT GETDATE() FOR autoDE", "tblAdjustment", tbl.Name)
DoCmd.RunSQL strSql

nextTbl:
Next tbl

cleanexit:
Exit Sub

errhandler:
MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Resume nextTbl
Resume cleanexit

errDropColumn:
'MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Resume SkipDropColumn

errDropConstraint:
'MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Resume SkipDropConstraint
End Sub



Public Sub RebuildAutoTs()
On Error GoTo errhandler

Dim tbl As AccessObject
Dim strSql As String

For Each tbl In CurrentData.AllTables

If LCase(Left(tbl.Name, 3)) = "sys" Then GoTo nextTbl

On Error GoTo errDropColumn
'drop the column
strSql = Replace("ALTER TABLE dbo.tblAdjustment DROP COLUMN autoTs", "tblAdjustment", tbl.Name)
DoCmd.RunSQL strSql
SkipDropColumn:
On Error GoTo errhandler
'add the column
strSql = Replace("ALTER TABLE dbo.tblAdjustment ADD autoTs timestamp NULL", "tblAdjustment", tbl.Name)
DoCmd.RunSQL strSql

nextTbl:
Next tbl

cleanexit:
Exit Sub

errhandler:
MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Resume nextTbl
Resume cleanexit

errDropColumn:
'MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Resume SkipDropColumn


End Sub

Public Sub RebuildAutoUE()
On Error GoTo errhandler

Dim tbl As AccessObject
Dim strSql As String

For Each tbl In CurrentData.AllTables

If LCase(Left(tbl.Name, 3)) = "sys" Then GoTo nextTbl
'
'
SkipDropColumn:
On Error GoTo errhandler
'add the column
strSql = Replace("ALTER TABLE dbo.tblAdjustment ADD autoUe varchar(50) NULL", "tblAdjustment", tbl.Name)
DoCmd.RunSQL strSql
'add the constraint
strSql = Replace("ALTER TABLE dbo.tblAdjustment ADD CONSTRAINT DF_tblAdjustment_autoUe DEFAULT (suser_sname()) FOR autoUe", "tblAdjustment", tbl.Name)
DoCmd.RunSQL strSql

nextTbl:
Next tbl

cleanexit:
Exit Sub

errhandler:
MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Resume nextTbl
Resume cleanexit

errDropColumn:
'MsgBox Err.Number & " - " & Err.Description, vbOKOnly
Resume SkipDropColumn
End Sub[code]