Option Compare Database
Option Explicit


'*******************************************************************************
' Project   : Generic
'             Copyright © 2000, 2008, 2011 Bill Mosca
' Module    : basDevToolbar
' DateTime  : 7/30/2008 07:09
' Author    : Bill Mosca, Leszynski Company, Inc.
' Purpose   :
' References:
' Source      : lci_basTbrDevlpmt, Version 12/23/96
'               Routines for development toolbar lci_tbrDevlpmt
'               Copyright (c) 1996 Leszynski Company, Inc.
'               May not be used without permission
'
'Last updated on 3/20/2013 10:38
'
'
'*****WARNING!*****
'Do not run dev_TbrBasIndex on this module. It will remove some code from
'that routine.
'*******************************************************************************

Private Const pstrVersion = "3/20/2013 10:38"
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Public Function dev_TbrBasIndex()
'Purpose  : Recreate module index
' A module must have focus when this is called.
' Be sure there is a blank line beteen the top of the page and the general declarations.
' If index already exists, it will be deleted so the updated one can replace it.
'          Starting line for index received from inputbox
'DateTime : 12/23/96
'Author   : lci
'Edited By: Bill Mosca
'Requires :

    On Error GoTo dev_TbrBasIndex_Err

    Dim blnRet As Boolean        ' Result of Find
    Dim bytType As Byte        ' Current object type
    Dim lngEndCol As Long        ' Find method argument
    Dim lngEndLine As Long        ' Find method argument
    Dim lngProcKind As Long        ' ProcOfLine method argument
    Dim lngStartCol As Long        ' Find method argument
    Dim lngStartLine As Long        ' Find method argument
    Dim bas As Module        ' The module to search
    Dim strIndex As String        ' The index
    Dim bolIndexExists As Boolean        'Is there an index?
    Dim lngIndexStartLn As Long        ' Line to start inserting index
    Dim lngIndexStartCol As Long
    Dim lngIndexEndLn As Long        'end of index
    Dim lngIndexEndCol As Long
    Dim lngIndexLnCt As Long
    Dim lngIndexNextLn As Long

    bytType = Application.CurrentObjectType        ' Object with focus

    ' The following line is inaccurate in the book text
    If bytType <> acModule Or _
            SysCmd(acSysCmdGetObjectState, bytType _
            , Application.CurrentObjectName) = 0 Then
        Beep
        GoTo dev_TbrBasIndex_Exit
    End If

    ' Get a pointer to the current module
    Set bas = Modules(Application.CurrentObjectName)
    strIndex = "' Index     :(Updated on " & Now() & ")" & vbCrLf
    bolIndexExists = bas.Find("' Index", lngIndexStartLn, lngIndexStartCol, lngIndexEndLn, _
            lngIndexEndCol, True, True)
    If bolIndexExists Then
        lngIndexLnCt = lngIndexStartLn + 1
        Do
            If InStr(bas.Lines(lngIndexLnCt, 1), "'") Then
                lngIndexLnCt = lngIndexLnCt + 1
            Else
                Exit Do
            End If
        Loop
        bas.DeleteLines lngIndexStartLn, lngIndexLnCt - (lngIndexStartLn - 1)
    End If


    ' Loop through the module and find each target string
    ' The find target is assembled in pieces so it is not found
    Do
        lngEndLine = bas.CountOfLines        ' Search to the end
        blnRet = bas.Find("'Purpose  :", lngStartLine, lngStartCol _
                , lngEndLine, lngEndCol, True, True)
        If blnRet Then        ' The string was found
            ' Add the found line's procedure name and purpose to index string
            strIndex = strIndex & "  ' " _
                    & bas.ProcOfLine(lngStartLine, lngProcKind) & " - " _
                    & Trim(Mid(bas.Lines(lngStartLine, 1), 12)) & vbCrLf
        Else
            Exit Do
        End If
        ' Increment the start of next find
        lngStartLine = lngStartLine + 1
    Loop
    ' Insert the index at the top of the module
    lngIndexStartLn = InputBox("Start Index at what line?")
    'Add Flower box line at end of string
    strIndex = strIndex & "'" & String(79, "*") & vbNewLine
    bas.InsertLines lngIndexStartLn, strIndex
    DoCmd.Save acModule, bas.Name
    MsgBox "Index created and module saved.", vbInformation, "Index Module"

    'Go back to module view.
    DoCmd.OpenModule bas.Name

dev_TbrBasIndex_Exit:
    Exit Function

dev_TbrBasIndex_Err:
    Resume dev_TbrBasIndex_Exit

End Function


Public Function dev_TbrCheckRptPrinter()
'Purpose  : Check all reports to see if printer is default printer or not.
'DateTime : 1/4/2008 14:48
'Author   : Bill Mosca
    Dim objAcc As AccessObject
    Dim rpt As Report
    Dim prtDefault As Printer
    Dim intResponse As Integer


    'Default printer
    Set prtDefault = Application.Printer

    For Each objAcc In CurrentProject.AllReports
        DoCmd.OpenReport objAcc.Name, acViewDesign
        Set rpt = Reports(objAcc.Name)
        If rpt.UseDefaultPrinter = False Then
            intResponse = MsgBox(rpt.Name & " does not use the default printer. " _
                    & "It is currently assigned to " & rpt.Printer.DeviceName & "." _
                    & vbNewLine & vbNewLine _
                    & "Set it to use the default printer?", _
                    vbYesNo)
            If intResponse = vbYes Then
                rpt.UseDefaultPrinter = True
            End If
        End If
        Set rpt = Nothing
        'Save and close report.
        DoCmd.Close acReport, objAcc.Name, acSaveYes
    Next

    Set rpt = Nothing
    Set prtDefault = Nothing

    MsgBox "Report printer analysis complete.", vbInformation

End Function


Public Function dev_TbrCheckRptTBR()
'Purpose  : Check to see if report has tbrPrintRptSnp
'DateTime : 2/20/2008 09:35
'Author   : Bill Mosca
'Reference:
    Dim doc As DAO.Document
    Dim db As DAO.Database

    On Error Resume Next

    Set db = CurrentDb

    For Each doc In db.Containers("Reports").Documents
        'Skip sub reports
        If doc.Name Like "*_sub" Then GoTo LoopMe
        DoCmd.OpenReport doc.Name, acDesign
        If Len(Reports(doc.Name).Toolbar & vbNullString) = 0 _
                Or Reports(doc.Name).Toolbar <> "tbrPrintRptSnp" Then
            If MsgBox("Print Toolbar not set for " & doc.Name _
                    & ". Do you want to set it?", _
                    vbQuestion + vbYesNo, "Print Toolbar Setting") = vbYes Then
                Reports(doc.Name).Toolbar = "tbrPrintRptSnp"
                'Hide menubar.
                If Reports(doc.Name).MenuBar <> "" Then
                    Reports(doc.Name).MenuBar = ""
                End If
            End If
        End If
        DoCmd.Close acReport, doc.Name, acSaveYes
LoopMe:
    Next

    MsgBox "All reports checked.", vbInformation
    Set db = Nothing

End Function


Function dev_TbrClearStatusTxt()
'Purpose  : Clear text from Statusbar
'DateTime : 5/21/2004 13:57
'Author   : Bill Mosca
'Requires :
    Dim vReturn
    SysCmd acSysCmdClearStatus

End Function


Public Function dev_TbrCloseFrmsRpts()
'Purpose  : Close all forms and reports opened in design view
'           except the current one.
'DateTime : 11/2/2007 07:46
'Author   : Bill Mosca
'Reference:
    Dim objObject As AccessObject
    Dim intPrompt As Integer
    Dim intUserResp As Integer


    'Set Save flag. Automatically save unless user wants prompt.
    'acSavePrompt=0; acSaveYes=1
    intUserResp = MsgBox("Objects will automatically be saved unless " _
            & "you specify a prompt." _
            & vbNewLine & vbNewLine _
            & "Prompt to save?", vbQuestion + vbYesNo + vbDefaultButton2, "Save?")

    Select Case intUserResp
        Case vbYes
            intPrompt = acSavePrompt
        Case vbNo
            intPrompt = acSaveYes
    End Select

    For Each objObject In CurrentProject.AllForms
        If objObject.IsLoaded = True _
                And Application.CurrentObjectName <> objObject.Name Then
            DoCmd.Close acForm, objObject.Name, intPrompt
        End If
    Next

    For Each objObject In CurrentProject.AllReports
        If objObject.IsLoaded = True _
                And Application.CurrentObjectName <> objObject.Name Then
            DoCmd.Close acReport, objObject.Name, intPrompt
        End If
    Next

End Function


Public Function dev_TbrColorLabel()
'Purpose  : Sets MouseMove event to ColorLabel function
'DateTime : 7/18/2008 14:39
'Author   : Bill Mosca
'Requires : basFormUtil
    Dim ctrl As Control
    Dim frm As Form

    If Application.CurrentObjectType <> acForm Then
        MsgBox "Set focus on the form.", vbInformation
        Exit Function
    End If

    Set frm = Forms(Application.CurrentObjectName)

    For Each ctrl In frm.Controls
        If ctrl.ControlType = acCommandButton And ctrl.Tag = "MM" Then
            ctrl.OnMouseMove = "=ColorLabel([" & ctrl.Name & "])"
        End If
    Next

    DoCmd.Save acForm, frm.Name
    Set frm = Nothing

End Function


Public Function dev_TbrFixBits()
'Purpose  : Set 0 default for bit fields.
'DateTime : 5/23/2007 10:46
'Author   : Bill Mosca
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim prop As DAO.Property
    Dim bytType As Byte

    On Error GoTo err_dev_TbrFixBits

    bytType = Application.CurrentObjectType        ' Object with focus

    'Make sure current object is a table selected in the DB window.
    If bytType <> acTable Then
        MsgBox "Select a table to update.", vbInformation
        GoTo exit_dev_TbrFixBits
    End If

    Set db = CurrentDb
    Set tdf = db.TableDefs(Application.CurrentObjectName)
    For Each fld In tdf.Fields
        If fld.Type = dbBoolean Then
            fld.DefaultValue = 0
            fld.Properties("DisplayControl") = acTextBox
            fld.Properties.Delete "Format"

        End If
    Next

    MsgBox "All bits default to zero", vbInformation

exit_dev_TbrFixBits:
    On Error Resume Next
    Set tdf = Nothing
    Set db = Nothing
    Exit Function

err_dev_TbrFixBits:
    Select Case Err.Number
        Case 3265
            Resume Next
        Case Else
            MsgBox Err.Description
    End Select
    Resume exit_dev_TbrFixBits

End Function


Public Function dev_TbrFixZLS()
'Purpose  : Disallow Zero length strings in all tables.
'DateTime : 8/14/2006 10:34
'Author   : Allen Browne
'Modified By: Bill Mosca to skip linked SQL tables on error.
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim prp As DAO.Property
    Const conPropName = "AllowZeroLength"
    Const conPropValue = False

    On Error Resume Next

    Set db = DBEngine(0)(0)
    For Each tdf In db.TableDefs
        If (tdf.Attributes And dbSystemObject) = 0 Then
            For Each fld In tdf.Fields
                If fld.Properties(conPropName) Then
                    fld.Properties(conPropName) = False
                End If
            Next
        End If
    Next

    MsgBox "'Allow Zero Length' has been set to No for all Access tables."

    Set prp = Nothing
    Set fld = Nothing
    Set tdf = Nothing
    Set db = Nothing

End Function


Public Function dev_TbrFormCaptionFix()
'Purpose  : Check all forms to fix missing captions
'DateTime : 1/05/2010 13:14
'Author   : Bill Mosca
'Requires :
    Dim doc As DAO.Document
    Dim db As DAO.Database
    Dim strCaption As String

    Set db = CurrentDb

    For Each doc In db.Containers("Forms").Documents
        DoCmd.OpenForm doc.Name, acDesign
        If Forms(doc.Name).Caption = "" Then
            strCaption = InputBox(doc.Name & " has no caption. Enter Caption or click Cancel to skip.", _
                    "Form Caption")
            Forms(doc.Name).Caption = strCaption
        End If
        DoCmd.Close acForm, doc.Name, acSaveYes
    Next

    MsgBox "All Forms checked for missing captions.", vbInformation
    Set db = Nothing


End Function


Public Function dev_TbrFormDesignViewOnly()
'Purpose  : Set AllowDesignChanges to Design view only
'DateTime : 7/30/2008 07:23
'Author   : Bill Mosca
'Requires :
    Dim doc As DAO.Document
    Dim db As DAO.Database

    Set db = CurrentDb

    For Each doc In db.Containers("Forms").Documents
        DoCmd.OpenForm doc.Name, acDesign
        Forms(doc.Name).AllowDesignChanges = False
        DoCmd.Close acForm, doc.Name, acSaveYes
    Next

    MsgBox "All Forms set to AllowDesignChanges=False", vbInformation
    Set db = Nothing

End Function


Public Function dev_TbrFormNoMenu()
'Purpose  : Hide default menu when form is open.
'DateTime : 3/20/2013 10:37
'Author   : Bill Mosca
    Dim doc As DAO.Document
    Dim db As DAO.Database
    Dim intResponse As Integer

    Set db = CurrentDb

    For Each doc In db.Containers("Forms").Documents
        If (doc.Name Like "*_sub") = True Then
            DoCmd.OpenForm doc.Name, acDesign
            Forms(doc.Name).MenuBar = ""
            DoCmd.Close acForm, doc.Name, acSaveYes
        Else
            DoCmd.OpenForm doc.Name, acDesign
            If Application.Version >= 14 Then
                Forms(doc.Name).MenuBar = ""
                Forms(doc.Name).RibbonName = "rbnMain"
            Else: Forms(doc.Name).MenuBar = "mnuBlank"
            End If
            DoCmd.Close acForm, doc.Name, acSaveYes
        End If
    Next

    MsgBox "All Forms set to MenuBar: 'mnuBlank'", vbInformation
    Set db = Nothing
    
End Function

Public Function dev_TbrHourglassOff()
'Purpose  : Turn off the hourglass cursor
'DateTime : 5/21/2004 13:57
'Author   : Bill Mosca
'Requires :

    On Error Resume Next
    DoCmd.Hourglass False

End Function


Public Function dev_TbrKillMonitors()
'Purpose  : Close the 2 monitoring forms that are open hidden by Startup
'DateTime : 7/30/2008 07:27
'Author   : Bill Mosca
'Requires :
    On Error GoTo err_PROC

    If CurrentProject.AllForms("frmAdminMsg").IsLoaded Then
        DoCmd.Close acForm, "frmAdminMsg"
    End If

    If CurrentProject.AllForms("frmInactiveShutDown").IsLoaded Then
        DoCmd.Close acForm, "frmInactiveShutDown"
    End If

    MsgBox "Monitoring forms closed.", vbInformation

exit_PROC:
    Exit Function

err_PROC:
    Select Case Err.Number
        Case 2467        'object is closed or doesn't exist.
            Resume Next
        Case Else: MsgBox Err.Description, vbCritical
    End Select

End Function


Public Function dev_TbrRelinkSQLTables()
MsgBox "Commented out"
'Purpose  : Relink FE to tables/views in SQL Server.
'           Includes resetting any __uniqueindex indices on views to allow updates.
'Uses Globals:
'           gconSQLDB (Database Name)
'           gconSQLServer (SQL Server Name)
'DateTime : 11/7/2003 14:00
'Author:    Bill Mosca
'    Dim cnn As ADODB.Connection        'NOTE:
'    Dim cat As ADOX.Catalog        'Change all ADOX objects to late binding if using 2007.
'    Dim tbl As ADOX.Table
'    Dim idx As ADOX.Index
'    Dim x As Integer
'    Dim strSQL As String
'    Dim aryCols()
'
'    On Error GoTo err_PROC
'
'    Set cnn = CurrentProject.Connection
'    Set cat = New ADOX.Catalog
'    cat.ActiveConnection = cnn
'
'    For Each tbl In cat.Tables
'        If tbl.Type = "PASS-THROUGH" Then
'            'Retrieve local unique index if there is one for the views.
'            If tbl.Indexes.Count > 0 Then
'                Set idx = tbl.Indexes("__uniqueindex")
'                '                If Err <> 0 Then GoTo LoopMe
'            End If
'
'            ReDim aryCols(idx.Columns.Count - 1)
'            For x = 0 To UBound(aryCols)
'                aryCols(x) = idx.Columns(x).NAME
'            Next
'
'            'Set Connect string
'            tbl.Properties("Jet OLEDB:Link Provider String") = _
'                    "ODBC;DRIVER=SQL Server Native Client 10.0;SERVER=" & gconSQLServer _
'                    & ";APP=Microsoft Open Database Connectivity;" _
'                    & "Trusted_Connection=Yes;DATABASE=" & gconSQLDB & ";"
'            strSQL = _
'                    "CREATE UNIQUE INDEX " & idx.NAME _
'                    & " ON " & tbl.NAME & "(" & Join(aryCols, ",") & ")"
'            cnn.Execute strSQL
'            '            CurrentDb.TableDefs(tbl.Name).RefreshLink
'
'        End If
'LoopMe:
'    Next
'
'
'    MsgBox "All SQL Tables/Views successfully linked."
'
'
'exit_PROC:
'    On Error Resume Next
'    Set idx = Nothing
'    Set cat = Nothing
'    Set cnn = Nothing
'    Exit Function
'
'err_PROC:
'    Select Case Err.Number
'            'These are all caused by no index of tdf.
'        Case 9, 91, 3078, 3265, -2147217908
'            Resume Next
'        Case -2147467259
'            'Table missing from back end so drop the link and warn that compact
'            'is necessary to remove temp table.
'            If MsgBox(tbl.NAME & " does not exist in BE." _
'                    & vbNewLine & vbNewLine _
'                    & "Do you want to delete the link?", _
'                    vbYesNo + vbQuestion, "Missing table!") = vbYes Then
'                cat.Tables.Delete tbl.NAME
'                MsgBox "Be sure to compact the FE when linking is finished."
'            Else
'                If MsgBox("Continue relinking", vbYesNo + vbQuestion) = vbNo Then Resume exit_PROC
'            End If
'
'            Resume LoopMe
'        Case Else
'Stop
'    End Select
'
'    Resume exit_PROC

End Function

Public Function dev_TbrRemoveCaptions()
'Purpose  : Remove Captions in tables.
'           Optionally, add Caption to end of Field Description
'           in parentheses (default is not to do this).
'DateTime : 8/28/2007 13:42
'Author   : Crystal
'Reference: DAO Library
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim intAddToDesc As Integer
    Dim intCtDone As Integer
    Dim intCtCkd As Integer

    On Error GoTo Proc_Err

    intCtDone = 0
    intCtCkd = 0
    intAddToDesc = MsgBox("Move Caption to Description?", vbQuestion + vbYesNo, "Update Description")

    For Each tdf In CurrentDb.TableDefs
        'skip Microsoft System tables
        If Left(tdf.Name, 4) <> "Msys" Then
            intCtCkd = intCtCkd + 1
            For Each fld In tdf.Fields
                If Len(Nz(fld.Properties("Caption"), "")) > 0 Then
                    If intAddToDesc = vbYes Then
                        Err.Number = 0
                        On Error Resume Next

                        fld.Properties("Description") = _
                                fld.Properties("Description") _
                                & " (" & fld.Properties("Caption") & ")"

                        If Err.Number > 0 Then
                            On Error GoTo Proc_Err
                            fld.Properties.Append _
                                    fld.CreateProperty("Description", _
                                    dbText, "(" & fld.Properties("Caption") & ")")
                        Else
                            On Error GoTo Proc_Err
                        End If
                    End If

                    fld.Properties.Delete "Caption"
                    intCtDone = intCtDone + 1
                End If
NextField:
            Next fld
        End If
    Next tdf


    MsgBox intCtCkd & " tables checked" & vbCrLf & vbCrLf _
            & "Removed Captions in  " _
            & intCtDone & " fields", vbInformation, "Remove Field Captions in Table Design"

Proc_Exit:
    On Error Resume Next
    Set fld = Nothing
    Set tdf = Nothing
    Exit Function

Proc_Err:
    Select Case Err.Number
            'Caption property not found
        Case 3270: Resume NextField
    End Select
    MsgBox Err.Description, , _
            "ERROR " & Err.Number _
            & "   RemoveCaptions"

    Resume Proc_Exit

End Function


Public Function dev_TbrRemoveLookups()
'Purpose  : Remove Lookups from tables. All properties that go with
'           a lookup must be removed as well.
'DateTime : 8/28/2007 13:39
'Author   : Crystal
'Reference: DAO Library
'Note     : Creates text file for all value lists in Temp folder.
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim intCtDone As Integer
    Dim intCtCkd As Integer
    Dim intFileNum As Integer
    Dim strTempFolder As String

    On Error GoTo Proc_Err

    intCtDone = 0
    intCtCkd = 0

    For Each tdf In CurrentDb.TableDefs
        'skip Microsoft System tables
        If Left(tdf.Name, 4) <> "Msys" Then
            intCtCkd = intCtCkd + 1
            For Each fld In tdf.Fields
                If fld.Properties("DisplayControl") = acComboBox _
                        Or fld.Properties("DisplayControl") = acListBox Then
                    With fld
                        Err = 0
                        If .Properties("RowSourceType") = "Value List" Then
                            'Use intFileNum to determine if csv file is open yet
                            If intFileNum = 0 Then
                                MsgBox "A Value List lookup was found. A delimited file " _
                                        & "named 'ValueList.csv' " _
                                        & "was created in your temp folder for appending all " _
                                        & "value lists found.", vbInformation
                                'Create a buffer
                                strTempFolder = String(255, Chr$(0))
                                'Get the temporary path
                                GetTempPath 100, strTempFolder
                                'Trim buffer
                                strTempFolder = _
                                        Left$(strTempFolder, InStr(strTempFolder, Chr$(0)) - 1)

                                intFileNum = FreeFile
                                Open strTempFolder & "ValueLists.csv" For Append As intFileNum
                                'Print field name header
                                Print #intFileNum, _
                                        "TableName|FieldName|ValueList"
                            End If
                            Print #intFileNum, _
                                    tdf.Name & "|" & fld.Name & "|" & .Properties("RowSource")
                        End If
                        .Properties("DisplayControl") = acTextBox
                        intCtDone = intCtDone + 1
                        .Properties.Delete "RowSource"
                        .Properties.Delete "ColumnCount"
                        .Properties.Delete "ColumnWidths"
                        .Properties.Delete "ListWidth"
                    End With
                End If
NextField:
            Next fld
        End If
    Next tdf


    MsgBox intCtCkd & " tables checked" & vbCrLf & vbCrLf _
            & "Reset Display control property to Textbox in " _
            & intCtDone & " fields where it was a combobox or listbox", _
            vbOK, "Set DisplayControl to Textbox"

Proc_Exit:
    On Error Resume Next
    If intFileNum <> 0 Then Close intFileNum
    Set fld = Nothing
    Set tdf = Nothing
    Exit Function

Proc_Err:
    Select Case Err.Number
            'DisplayControl property not found
        Case 3270: Resume NextField
            'other property not found
        Case 3265: Resume Next
    End Select
    MsgBox Err.Description, , _
            "ERROR " & Err.Number _
            & "   RemoveLookups"

    Resume Proc_Exit

End Function


Public Function dev_TbrRemoveOrderByProperty()
'Purpose  : Remove OrderBy properties in tables.
'DateTime : 1/30/2008 10:24
'Author   : Bill Mosca
'Reference: DAO
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field

    On Error GoTo err_dev_RemoveOrderByProperty

    DoCmd.Hourglass True

    For Each tdf In CurrentDb.TableDefs
        'skip Microsoft System tables
        If Left(tdf.Name, 4) <> "Msys" Then
            SysCmd acSysCmdSetStatus, "Checking " & tdf.Name & "..."
            For Each fld In tdf.Fields
                If Len(fld.Properties("Order By") & vbNullString) > 0 Then
                    fld.Properties("Order By") = ""
                End If
NextField:
            Next
        End If
    Next

    MsgBox "All tables checked and corrected.", vbInformation
    SysCmd acSysCmdClearStatus

exit_dev_RemoveOrderByProperty:
    On Error Resume Next
    DoCmd.Hourglass False
    Exit Function

err_dev_RemoveOrderByProperty:
    Select Case Err.Number
            'Property not found
        Case 3270
            Resume NextField
        Case Else
            MsgBox Err.Description, , _
                    "ERROR " & Err.Number _
                    & "   RemoveCaptions"
    End Select


    Resume exit_dev_RemoveOrderByProperty

End Function


Public Function dev_TbrRenameDBOTables()
MsgBox "commented out"
'Purpose  : Remove SQL Server "dbo_" from all table names.
'DateTime : 10/28/2000 15:17
'Author   : Bill Mosca
'    Dim cnn As ADODB.Connection
'    Dim cat As ADOX.Catalog
'    Dim tbl As ADOX.Table
'    Dim strPrefix As String
'
'    On Error GoTo err_RenameDBOTables
'
'    strPrefix = "dbo_"
'    Set cnn = CurrentProject.Connection
'    Set cat = New ADOX.Catalog
'    cat.ActiveConnection = cnn
'    For Each tbl In cat.Tables
'        If tbl.NAME Like strPrefix & "*" Then
'            tbl.NAME = Mid(tbl.NAME, Len(strPrefix) + 1)
'        End If
'    Next
'
'    Application.RefreshDatabaseWindow
'    MsgBox "Tables successfully renamed.", vbInformation, "dbo_ Dropped"
'
'exit_RenameDBOTables:
'    On Error Resume Next
'    Set cat = Nothing
'    Set cnn = Nothing
'    Exit Function
'
'err_RenameDBOTables:
'    Select Case Err.Number
'
'        Case Else
'            MsgBox "An error (" & Err.Description & ") occurred in RenameDBOTables.", vbCritical, "Error!"
'    End Select
'
'    Resume exit_RenameDBOTables


End Function

Public Function dev_TbrRestart()
'Purpose  : Run the startup form
'DateTime : 12/23/96
'Author   : lci
'Requires :
    Const cintErrPropNotFound As Integer = 3270
    Dim dbsCurr As DAO.Database
    Dim strForm As String
    Dim frm As Object

    On Error GoTo dev_TbrRestart_Err



    Set dbsCurr = CurrentDb
    ' If the property is not set, this kicks to custom error handler
    strForm = dbsCurr.Properties("StartupForm")        ' Get the icon
    If strForm <> "" Then
        'Trim "Form." off of name. Access StartupForm property is "Form.MyForm"
        If Left(strForm, 5) = "Form." Then
            strForm = Mid(strForm, 6)
        End If

        DoCmd.OpenForm strForm
    End If

dev_TbrRestart_Exit:
    On Error Resume Next
    dbsCurr.Close
    Exit Function

dev_TbrRestart_Err:
    ' Trap the non-existence of the property
    If Err.Number = cintErrPropNotFound Then
        ' Create the property in the database
        If IsNull(strForm) Or strForm = "" Then        ' Cannot set property to Null
            Beep
            If MsgBox("Application has no startup form assigned." _
                    & vbNewLine & vbNewLine _
                    & "Try Switchboard as startup?", _
                    vbQuestion + vbYesNo, "dev_TbrRestart") = vbYes Then
                For Each frm In CurrentProject.AllForms
                    If frm.Name = "Switchboard" Then
                        DoCmd.OpenForm frm.Name
                        Resume dev_TbrRestart_Exit
                    End If
                Next
                MsgBox "Switchboard does not exist.", vbInformation
            End If
        End If
        GoTo dev_TbrRestart_Exit
    Else
        MsgBox "No startup form for this Database."
        Resume dev_TbrRestart_Exit
    End If

End Function


Public Function dev_TbrTglBoAE()
'Purpose  : Turn Break on All Errors on or off
'DateTime : 12/23/96
'Author   : lci
'Requires :
    Dim bolState As Boolean
    Dim iUserResponse As Integer
    Dim strOption As String

    strOption = "Break on All Errors"

    bolState = Application.GetOption(strOption)
    iUserResponse = MsgBox(strOption & " Warning is " & IIf(bolState, "ON", "OFF") & _
            "." & vbNewLine & "Do you want to change the setting?", vbYesNo)

    If iUserResponse = vbYes Then
        Application.SetOption strOption, Not bolState
    End If

End Function


Function dev_TbrTglDocWarnings()
'Purpose  : Tell User if Document Deletion Warnings are on/off and prompt to change it.
'DateTime : 12/23/96
'Author   : lci
'Requires :
    Dim bolState As Boolean
    Dim iUserResponse As Integer
    Dim strOption As String

    strOption = "Confirm Document Deletions"

    bolState = Application.GetOption(strOption)
    iUserResponse = MsgBox(strOption & " Warning is " & IIf(bolState, "ON", "OFF") & _
            "." & vbNewLine & "Do you want to change the setting?", vbYesNo)

    If iUserResponse = vbYes Then
        Application.SetOption strOption, Not bolState
    End If

End Function


Function dev_TbrTglQWarnings()
'Purpose  : Tell User if Action Query Warnings are on/off and prompt to change them.
'DateTime : 12/23/96
'Author   : lci
'Requires :
    Dim bolState As Boolean
    Dim iUserResponse As Integer
    Dim strOption As String

    strOption = "Confirm Action Queries"

    bolState = Application.GetOption(strOption)
    iUserResponse = MsgBox(strOption & " Warning is " & IIf(bolState, "ON", "OFF") & _
            "." & vbNewLine & "Do you want to change the setting?", vbYesNo)

    If iUserResponse = vbYes Then
        Application.SetOption strOption, Not bolState
    End If


End Function


Function dev_TbrTglRecWarnings()
'Purpose  : Tell User if Record Deletion Warnings are on/off and prompt to change them.
'DateTime : 12/23/96
'Author   : lci
'Requires :
    Dim bolState As Boolean
    Dim iUserResponse As Integer
    Dim strOption As String

    strOption = "Confirm Record Changes"

    bolState = Application.GetOption(strOption)
    iUserResponse = MsgBox(strOption & " Warning is " & IIf(bolState, "ON", "OFF") & _
            "." & vbNewLine & "Do you want to change the setting?", vbYesNo)

    If iUserResponse = vbYes Then
        Application.SetOption strOption, Not bolState
    End If

End Function


Public Function dev_TbrToggleSysObjects()
'Purpose  : Show/Hide System Objects.
'DateTime : 5/21/2004 13:57
'Author   : Bill Mosca
    Dim bolOptionOn As Boolean
    bolOptionOn = Application.GetOption("Show System Objects")
    Application.SetOption "Show System Objects", Not bolOptionOn
    Application.RefreshDatabaseWindow

End Function


Public Function dev_TbrTurnOffSubDataSheets()
'Purpose  : Access sets all tables' SubDataSheets to Auto which slows up loading time.
'           This function will set the property to [none].
'DateTime : 1/14/2004 09:20
'Author   : Bill Mosca
    Dim db As DAO.Database
    Dim prop As DAO.Property
    Dim propName As String, propVal As String
    Dim propType As Integer, i As Integer

    On Error Resume Next

    Set db = CurrentDb

    propName = "SubDataSheetName"
    propType = 10
    propVal = "[NONE]"


    For i = 0 To db.TableDefs.Count - 1

        If (db.TableDefs(i).Attributes And dbSystemObject) = 0 Then

            If db.TableDefs(i).Properties(propName).Value <> propVal Then
                db.TableDefs(i).Properties(propName).Value = propVal
            End If

            If Err.Number = 3270 Then
                Err.Clear
                Set prop = db.TableDefs(i).CreateProperty(propName)
                prop.Type = propType
                prop.Value = propVal
                db.TableDefs(i).Properties.Append prop
            Else
                If Err.Number <> 0 Then
                    Resume Next
                End If
            End If

        End If
    Next i

    MsgBox "The " & propName & _
            " value for all non-system tables has been updated to " & propVal & "."

    Set prop = Nothing
    Set db = Nothing

End Function


Public Function dev_TbrUnhideObjects()
'Purpose  : Unhide hidden objects
'DateTime : 6/15/2011 13:54
'Author   : Bill Mosca
'Requires : DAO
    Dim db As DAO.Database
    Dim cntr As DAO.Container
    Dim doc As DAO.Document

    On Error GoTo err_PROC

    Set db = CurrentDb

    Set cntr = db.Containers("Forms")
    For Each doc In cntr.Documents
        'Show Forms hidden in DB window.
        If Application.GetHiddenAttribute(acForm, doc.Name) = True Then
            Application.SetHiddenAttribute acForm, doc.Name, False
        End If
        'Show Forms that are open but hidden.
        If CurrentProject.AllForms(doc.Name).IsLoaded Then
            If Forms(doc.Name).Visible = False Then
                Forms(doc.Name).Visible = True
            End If
        End If
    Next

    Set cntr = db.Containers("Reports")
    For Each doc In cntr.Documents
        'Show Reports hidden in DB window.
        If Application.GetHiddenAttribute(acReport, doc.Name) = True Then
            Application.SetHiddenAttribute acReport, doc.Name, False
        End If
        'Show Reports that are open but hidden.
        If CurrentProject.AllReports(doc.Name).IsLoaded Then
            If Reports(doc.Name).Visible = False Then
                Reports(doc.Name).Visible = True
            End If
        End If

    Next

    Set cntr = db.Containers("Tables")        'takes care of tables and queries
    For Each doc In cntr.Documents
        If Application.GetHiddenAttribute(acTable, doc.Name) = True Then
            Application.SetHiddenAttribute acTable, doc.Name, False
        End If
    Next

    Set cntr = db.Containers("Modules")
    For Each doc In cntr.Documents
        If Application.GetHiddenAttribute(acModule, doc.Name) = True Then
            Application.SetHiddenAttribute acModule, doc.Name, False
        End If
    Next

    Set cntr = db.Containers("Scripts")        'macros
    For Each doc In cntr.Documents
        If Application.GetHiddenAttribute(acMacro, doc.Name) = True Then
            Application.SetHiddenAttribute acMacro, doc.Name, False
        End If
    Next

    MsgBox "All hidden objects are now visble", vbInformation


exit_PROC:
    On Error Resume Next
    Set cntr = Nothing
    Set db = CurrentDb
    Exit Function

err_PROC:
    Dim strErrMsg As String
    Dim lngErrIconBtn As Long

    Select Case Err.Number
        Case 2016
            'System table can't be edited.
            Resume Next
        Case Else
            strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") " _
                    & "occurred in procedure UnhideFormsReports of " _
                    & "VBA Document Module1"
            lngErrIconBtn = vbOKOnly + vbInformation

            MsgBox strErrMsg, lngErrIconBtn, "Error"

            Resume exit_PROC
    End Select

End Function

Public Function dev_TbrVersion()
'Purpose  : Display Last Updated date and info
'DateTime : 1/31/2008 10:15
'Author   : Bill Mosca
'Reference:
    MsgBox "Last Updated on " & Format(pstrVersion, "mm/dd/yyyy") _
            & vbNewLine & vbNewLine _
            & "Some routines for development toolbar taken from routines for lci_tbrDevlpmt." _
            & vbNewLine _
            & "Copyright (c) 1996 Leszynski Company, Inc." _
            & vbNewLine & vbNewLine _
            & "Others authored by Bill Mosca." _
            & "Copyright (c) 2000 - 2013 Bill Mosca"

End Function

Public Function dev_TbrViewCode()
'Purpose  : Change form or report object into design view and show code
'            Issue from the Database window or on an open object
'DateTime : 12/23/96
'Author   : lci
'Requires :
    On Error GoTo dev_TbrViewCode_Err

    Dim bytState As Byte
    Dim bytType As Byte
    Dim strName As String

    bytType = Application.CurrentObjectType
    strName = Application.CurrentObjectName

    If bytType = acForm Or bytType = acModule Or bytType = acReport Then
        bytState = SysCmd(acSysCmdGetObjectState, bytType, strName)        ' Get object state
        If bytState = acObjStateOpen Then        ' If open
            RunCommand acCmdDesignView        ' Toggle to design view
        End If
        RunCommand acCmdViewCode        ' Execute View Code
    End If

dev_TbrViewCode_Exit:
    Exit Function

dev_TbrViewCode_Err:
    Resume dev_TbrViewCode_Exit

End Function


Function dev_TbrWhoAmI()
'Purpose  : Show message box with CurrentUser. So I can see who I logged in as.
'DateTime : 7/30/2008 07:18
'Author   : Bill Mosca
'Requires :
    MsgBox "You are logged in as " & CurrentUser _
            & " using wrkgrp " & DBEngine.SystemDB & ".", vbInformation, "Who Am I?"

End Function