Microsoft Access modAccess

From database24
Revision as of 13:19, 1 July 2010 by Dec (talk | contribs) (Created page with '=== getApplicationTitle === <syntaxhighlight lang="vb"> Function getApplicationTitle() As String Dim strResult As String strResult = CurrentDb.Properties("AppTitle")...')
(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)
Jump to navigation Jump to search

getApplicationTitle

Function getApplicationTitle() As String
    Dim strResult As String
    
    strResult = CurrentDb.Properties("AppTitle").Value
    
    getApplicationTitle = strResult
End Function

getProjectName

The first guess for this is usually CurrentProject.Name but unfortunately this just returns the name of the file. If you want to bind your settings to a certain project, you certainly don't want to rely on the exact naming of a file; to the contrary you want to be able to use your stored settings no matter what the database file is named. 

Function getProjectName() As String
    Dim strResult As String
    
    strResult = Application.VBE.ActiveVBProject.Name
    
    getProjectName = strResult
End Function

setAccessAttribute / setupAccessAttributes

Public Function setAccessAttribute( _
    strName As String, _
    varType As Variant, _
    varValue As Variant _
    ) As Boolean
    Dim blnResult As Boolean
    
    Dim dbs As Database
    Dim prp As Property
    
    Set dbs = CurrentDb
    On Error GoTo handleSetAccessAttributeError
    dbs.Properties(strName) = varValue
    blnResult = True
    
    setAccessAttribute = blnResult
    Exit Function
    
handleSetAccessAttributeError:
    If Err.Number = 3270 Then
        'Property not found
        Set prp = dbs.CreateProperty(strName, varType, varValue)
        dbs.Properties.Append prp
        Resume Next
     Else
        'Unknown error
        blnResult = False
     End If
End Function

Public Sub setupAccessAttributes()
    'Application
    setAccessAttribute "AppTitle", dbText, getProject
    setAccessAttribute "AppIcon", dbText, "d:\project\appicon.ico"

    'Startup
    setAccessAttribute "StartupForm", dbText, "frmMain"
    setAccessAttribute "StartupShowDbWindow", dbBoolean, False
    setAccessAttribute "StartupShowStatusBar", dbBoolean, True

    'Allowance
    setAccessAttribute "AllowFullMenus", dbBoolean, True
    setAccessAttribute "AllowBuiltinToolbars", dbBoolean, True
    setAccessAttribute "AllowToolbarChanges", dbBoolean, False
    setAccessAttribute "AllowShortcutMenus", dbBoolean, True
    setAccessAttribute "AllowBreakIntoCode", dbBoolean, True
    setAccessAttribute "AllowSpecialKeys", dbBoolean, True
    setAccessAttribute "AllowBypassKey", dbBoolean, True
End Sub

setDebug / isDebug

Sub setDebug(blnDebug As Boolean)
    saveSetting getProjectName, "RunTime", "Debug", CStr(blnDebug)
End Sub

Function isDebug() As Boolean
    Dim blnResult As Boolean
    
    blnResult = CBool(GetSetting(getProjectName, "RunTime", "Debug", 0))
    
    isDebug = blnResult
End Function

existsTable

Function existsTable(strTable As String) As Boolean
    Dim blnResult As Boolean
    Dim tdf As TableDef
    
    blnResult = False
    For Each tdf In CurrentDb.TableDefs
        If tdf.Name = strTable Then
            blnResult = True
            Exit For
        End If
    Next
    
    existsTable = blnResult
End Function

existsQuery

Function existsQuery(strQuery As String) As Boolean
    Dim blnResult As Boolean
    Dim qdf As QueryDef
    
    blnResult = False
    For Each qdf In CurrentDb.QueryDefs
        If qdf.Name = strQuery Then
            blnResult = True
            Exit For
        End If
    Next
    
    existsQuery = blnResult
End Function

setTableDescription / getTableDescription

The property "Description" is not initially present in a table definition. Therefore it has to be created and appended to the property collection of the table definition on first usage. 

Sub setTableDescription(strTable As String, strDescription As String)
    Dim dbs As Database
    Dim tdf As TableDef
    Dim prp As Property
    
    Set dbs = CurrentDb
    Set tdf = dbs.TableDefs(strTable)
    
    On Error GoTo handleSetTableDescriptionError
    tdf.Properties("Description").Value = strDescription
    On Error GoTo 0
    Exit Sub
    
handleSetTableDescriptionError:
    If Err.Number = 3270 Then
        Set prp = tdf.CreateProperty("Description", dbText, strDescription)
        tdf.Properties.Append prp
        Resume Next
    Else
        MsgBox Err.Number & ": " & Err.Description
    End If
End Sub

Public Function getTableDescription(strTable As String) As String
    Dim strResult As String

    On Error Resume Next
    strResult = CurrentDb.TableDefs(strTable).Properties("Description").Value
    On Error GoTo 0
    
    getTableDescription = strResult
End Function

inList

Public Function inList(cmb As ComboBox, var As Variant) As Boolean
    Dim blnResult As Boolean
    Dim intIndex As Integer
    
    blnResult = False
    With cmb
        For intIndex = Abs(.ColumnHeads) To .ListCount - 1
            If CLng(.ItemData(intIndex)) = CLng(Nz(var)) Then
                blnResult = True
                Exit For
            End If
        Next
    End With
    
    inList = blnResult
End Function

displayActiveUsers

The usage of the Windows Script Host Object in order to identify the user's workstation is optional. 

Sub displayActiveUsers()
    Dim strUsers As String
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim wshNet As WshNetwork

    strUsers = "Computer Name"
    Set cn = CurrentProject.Connection
    Set rs = cn.OpenSchema( _
        Schema:=adSchemaProviderSpecific, _
        SchemaId:="{947bb102-5d43-11d1-bdbf-00c04fb92675}" _
        )
    Debug.Print _
        rs.Fields(0).Name & " " & _
        rs.Fields(1).Name ' & " " & _
        rs.Fields(2).Name & " " & _
        rs.Fields(3).Name
    Set wshNet = New WshNetwork
    With rs
        Do While Not .EOF
            strUsers = strUsers & vbCrLf & Chr$(149) & "  " & Left(.Fields(0).Value, Len(wshNet.ComputerName))
            If Left(.Fields(0).Value, Len(wshNet.ComputerName)) = wshNet.ComputerName Then
                strUsers = strUsers & " (me)"
                Debug.Print _
                    wshNet.ComputerName & "*     " & _
                    wshNet.UserName ' & " " & _
                    .Fields(2).Value & " " & _
                    .Fields(3).Value
            Else
                Debug.Print _
                    Left(.Fields(0).Value, Len(wshNet.ComputerName)) & "      " & _
                    Trim(.Fields(1).Value) ' & " " & _
                    .Fields(2).Value & " " & _
                    .Fields(3).Value
            End If
            .MoveNext
        Loop
    End With
    MsgBox strUsers, vbOKOnly, "Current Users"
End Sub

linkTable

Public Sub linkTable( _
    strTable As String, _
    strFilePath As String, _
    Optional strTableSource As String = "" _
    )
    Dim dbs As Database
    Dim tdf As TableDef
    
    If strTableSource = "" Then
        strTableSource = strTable
    End If
    
    setStatus "Linking table '" & strTable & "' to " & strFilePath & " (" & strTableSource & ") ..."
    Set dbs = CurrentDb
    If existsTable(strTable) Then
        DoCmd.DeleteObject acTable, strTable
    End If
    Set tdf = dbs.CreateTableDef(strTable)
    With tdf
        .Connect = ";DATABASE=" & strFilePath
        .SourceTableName = strTableSource
    End With
    dbs.TableDefs.Append tdf
    setTableDescription strTable, strFilePath
    setStatus
End Sub

updateForms

This method is used to reflect global changes in all open forms. The error handling is necessary in case a corresponding method should be missing. 

Public Sub updateForms()
    Dim aob As AccessObject
    
    For Each aob In CurrentProject.AllForms
        With aob
            If .IsLoaded Then
                On Error Resume Next
                Forms.Item(.Name).updateForm
                On Error GoTo 0
            End If
        End With
    Next
End Sub

In order to use this, two prerequisites must be met, which will be illustrated using a combo box which display a customer (cmbCustomer) and should reflect changes of a globally stored customer id (using setCustomerId / getCustomerId, for example):

  • the changing procedure must call updateForms after the value has been changed
Private Sub cmbCustomer_AfterUpdate()
    setCustomerId cmbCustomer.Value
    updateForms
End Sub
  • every form, which uses the customer id, must have a public method "updateForm" which is responsible for reflecting the change in the form (or report).
Public Sub updateForm()
    cmbCustomer.Value = getCustomerId
End Sub

removeDeprecatedObjects

Public Sub removeDeprecatedObjects(Optional blnExecute As Boolean = False)
    'All objects
    removeObjects "^[z]?_.*", blnExecute
    removeObjects "[0-9]{6}", blnExecute
    removeObjects "_alt[0-9]*$", blnExecute
    
    'Specific tables
    removeTables "(einfüge|import)fehler", blnExecute
    removeTables "^(temp|test)", blnExecute
    
    'Specific queries
    removeQueries "^abfrage", blnExecute
    
    'Specific forms
    
    'Specific reports
    
    If Not blnExecute Then
        Debug.Print
        Debug.Print _
            "If you would like to delete the above mentioned objects," & vbCrLf & _
            "please run 'removeDeprecatedObjects true'."
    End If
End Sub

removeObjects

Public Sub removeObjects(strPattern As String, Optional blnExecute As Boolean = False)
    removeTables strPattern, blnExecute
    removeQueries strPattern, blnExecute
    removeForms strPattern, blnExecute
    removeReports strPattern, blnExecute
End Sub

removeTables

Public Sub removeTables(strPattern As String, Optional blnExecute As Boolean = False)
    Dim tdf As TableDef
    Dim strTable As String
 
    For Each tdf In CurrentDb.TableDefs
        strTable = tdf.Name
        If matches(strTable, strPattern) Then
            setStatus "Removing table '" & strTable & "' ..."
            Debug.Print "Removing table '" & strTable & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acTable, strTable
            End If
        End If
    Next
    setStatus
End Sub

removeQueries

Public Sub removeQueries(strPattern As String, Optional blnExecute As Boolean = False)
    Dim qdf As QueryDef
    Dim strQuery As String
 
    For Each qdf In CurrentDb.QueryDefs
        strQuery = qdf.Name
        If matches(strQuery, strPattern) Then
            setStatus "Removing query '" & strQuery & "' ..."
            Debug.Print "Removing query '" & strQuery & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acQuery, strQuery
            End If
        End If
    Next
    setStatus
End Sub

removeForms

Public Sub removeForms(strPattern As String, Optional blnExecute As Boolean = False)
    Dim afs As AllForms
    Dim aob As AccessObject
    Dim strForm As String
 
    Set afs = CurrentProject.AllForms
    For Each aob In afs
        strForm = aob.Name
        If matches(strForm, strPattern) Then
            setStatus "Removing Form '" & strForm & "' ..."
            Debug.Print "Removing Form '" & strForm & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acForm, strForm
            End If
        End If
    Next
    setStatus
End Sub

removeReports

Public Sub removeReports(strPattern As String, Optional blnExecute As Boolean = False)
    Dim arp As AllReports
    Dim aob As AccessObject
    Dim strReport As String
 
    Set arp = CurrentProject.AllReports
    For Each aob In arp
        strReport = aob.Name
        If matches(strReport, strPattern) Then
            setStatus "Removing Report '" & strReport & "' ..."
            Debug.Print "Removing Report '" & strReport & "' ..."
            If blnExecute Then
                DoCmd.DeleteObject acReport, strReport
            End If
        End If
    Next
    setStatus
End Sub

setTableFieldType

Public Sub setTableFieldType(strTable As String, strField As String, strType As String)
    Dim strSql As String
 
    strSql = _
        "ALTER TABLE " & strTable & " ALTER COLUMN " & strField & " " & strType
    executeSql strSql
End Sub

setTableFieldFormat

Public Sub setTableFieldFormat(strTable As String, strField As String, strFormat As String)
    Dim db As Database
    Dim tdf As TableDef
    Dim fld As Field
    Dim prp As Property
    
    Set db = CurrentDb
    Set tdf = db.TableDefs(strTable)
    Set fld = tdf.Fields(strField)
    On Error GoTo handleSetTableFieldFormatError
    fld.Properties("Format") = strFormat
    On Error GoTo 0
    tdf.Fields.Refresh
    Exit Sub
    
handleSetTableFieldFormatError:
    If Err.Number = 3270 Then
        fld.Properties.Append tdf.CreateProperty("Format", dbText, strFormat)
    End If
    Resume Next
End Sub

displayGaps

Public Sub displayGaps( _
    strTable As String, _
    Optional strField As String = "Id", _
    Optional lngStart = 1, _
    Optional lngEnd = -1, _
    Optional lngLength = -1, _
    Optional lngCount = -1 _
    )

    Dim strTableMissing As String
    Dim strSql As String
    
    strTableMissing = "_" & strTable & "_Missing_" & strField
    strSql = _
        "   SELECT Current.Id - 1      AS MissingId             " & vbCrLf & _
        "     INTO " & strTableMissing & "                      " & vbCrLf & _
        "     FROM " & strTable & "    AS [Current]             " & vbCrLf & _
        "LEFT JOIN " & strTable & "    AS Previous              " & vbCrLf & _
        "       ON Current.Id           = Previous.Id + 1       " & vbCrLf & _
        "    WHERE Current.Id           > " & lngStart + 1 & "  " & vbCrLf & _
        "      AND Previous.Id         IS NULL                  "
    If lngEnd <> -1 Then
        strSql = strSql & _
            "      AND Current.Id           < " & lngEnd + 1 & "    "
    End If
    If lngCount <> -1 Then
        strSql = Replace(strSql, "SELECT", "SELECT TOP " & lngCount)
    End If
    executeSql strSql
    
    DoCmd.OpenTable strTableMissing
End Sub

turnOffSubDataSheets

Public Sub turnOffSubDataSheets()
    Dim db As Database
    Dim tdf As TableDef
    Dim prp As Property
    Dim strProperty As String
    Dim strValueRight As String
    Dim strValueWrong As String
    
    setStatus "Removing sub data sheets ..."
    Set db = CurrentDb
    strProperty = "SubDataSheetName"
    strValueRight = "[None]"
    strValueWrong = "[Auto]"
    
    For Each tdf In db.TableDefs
        With tdf
            If (.Attributes And dbSystemObject) = 0 Then
                On Error GoTo handlePropertyError
                If .Properties(strProperty).Value = strValueWrong Then
                    setStatus "Removing sub data sheets " & .Name & " ..."
                    .Properties(strProperty).Value = strValueRight
                    setStatus "Removing sub data sheets ..."
                End If
                On Error GoTo 0
            End If
        End With
    Next
    db.Close
    setStatus
    Exit Sub
    
handlePropertyError:
    With Err
        If .Number = 3270 Then
            Set prp = tdf.CreateProperty(strProperty)
            prp.Type = 10
            prp.Value = strValueRight
            tdf.Properties.Append prp
        Else
            Debug.Print .Number & " : " & .Description
        End If
        .Clear
    End With
    Resume Next
End Sub
Retrieved from "http://wiki.database24.net/index.php?title=Microsoft_Access_modAccess&oldid=126"