Access Data Projects Utilities

Category:

Office/VBA

Type:

Modules

Difficulty:

Beginning

Author: aaron

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.

Declarations:
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)

Code:

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