Data Watch - Einsatz am Limit

Funktionen in einem Modul sammeln

Beispielhaft sollen die Funktionen aus Listing 10 getestet werden. Der Parameter booAction dient als Umschalter, ob die Funktion mit der Angabe False nur einen Rückgabewert liefern oder mit True auch Aktionen auslösen soll. Alle Funktionen stehen im Modul modFunktionen und beginnen mit fncSTOP, fncMLDG oder fncINFO. Um diese Funktionsnamen mit ihren Ergebnissen ebenfalls in die Union-Abfrage aufzunehmen, wird der Code wie in Listing 11 erweitert.

Const dblMaxDBGroesse = 1.5 * 1024 * 1024
Function fncSTOPDatenbankGröße(Optional booAction As _
Boolean = False) As Double
Dim strText As String
strText = "Aktuelle Dateigröße:" & vbTab & _
Format(FileLen(CurrentDb.Name) / 1024 / 1024, _
"#,##0.00") & " MBytes" & vbCrLf & _
"Erwünschte Dateigröße:" & vbTab & _
Format(dblMaxDBGroesse / 1024 / 1024, _
"#,##0.00") & " MBytes" & vbCrLf & vbCrLf
If FileLen(CurrentDb.Name) > dblMaxDBGroesse Then
fncSTOPDatenbankGröße = FileLen(CurrentDb.Name)
If booAction Then
strText = strText & "Bitte komprimieren Sie die Datenbank."
MsgBox strText, vbCritical
End If
Else
fncSTOPDatenbankGröße = 0
If booAction Then
strText = strText & "Die Datenbank ist klein genug."
MsgBox strText, vbInformation
End If
End If
End Function
Function fncTest(Optional booAction As Boolean = False) As Integer
fncTest = 99
If booAction Then
MsgBox "Dieser Test ist sinnlos.", vbInformation
End If
End Function
Function fncMLDGAnzahlAdministratoren(Optional booAction As _
Boolean = False) As Integer
Dim intAdmins As Integer
intAdmins = Workspaces(0).Groups("Admins").Users.Count
'mehr als einer soll gemeldet werden
If intAdmins > 1 Then
fncMLDGAnzahlAdministratoren = intAdmins
If booAction Then
DoCmd.RunCommand acCmdUserAndGroupAccounts
End If
Else
fncMLDGAnzahlAdministratoren = 0
If booAction Then
MsgBox "Alles OK, es gibt nur einen Administrator.", _
vbInformation
End If
End If
End Function

Sub GrenzwerteUndFunctionsMitUNION()
Dim qryJede As QueryDef
Dim modFunkt As Module
Dim strSQL As String
Dim strZeile As String, strZeileAlt As String
Dim lngZeilenNr As Long
Dim lngAnzahl As Long
For Each qryJede In CurrentDb.QueryDefs
Select Case LCase(Left(qryJede.Name, 7))
Case "qryinfo", "qrymldg", "qrystop"
lngAnzahl = DCount("*", qryJede.Name)
If lngAnzahl > 0 Then
strSQL = strSQL & _
"SELECT """ & Mid(qryJede.Name, 4, 4) & _
""" As QTyp, """ & Mid(qryJede.Name, 8) & _
""" As QName, " & lngAnzahl & " As QAnzahl, " & _
"""Query"" As QQuelle " & _
"FROM [" & qryJede.Name & "] UNION" & vbCrLf
End If
End Select
Next
Set modFunkt = Modules("modFunktionen")
For lngZeilenNr = 1 To modFunkt.CountOfLines
strZeile = modFunkt.ProcOfLine(lngZeilenNr, vbext_pk_Proc)
If InStr(strZeile, "fnc") And strZeile <> strZeileAlt Then
Select Case LCase(Left(strZeile, 7))
Case "fncinfo", "fncmldg", "fncstop"
lngAnzahl = Eval(strZeile & "(0)")
If lngAnzahl > 0 Then
strSQL = strSQL & _
"SELECT """ & Mid(strZeile, 4, 4) & _
""" As QTyp, """ & Mid(strZeile, 8) & _
""" As QName, " & lngAnzahl & _
" As QAnzahl, " & _
"""VBA"" As QQuelle " & _
"FROM [MSysObjects] UNION" & vbCrLf
End If
End Select
strZeileAlt = strZeile
End If
Next
Set qryJede = CurrentDb.QueryDefs("qryUNION")
qryJede.SQL = Left(strSQL, Len(strSQL) - Len("UNION" & vbCrLf))
End Sub

Damit die Konstante vbext_pk_Proc definiert ist, muss entweder der Verweis auf Microsoft Visual´Basic for Applications Extensibility eingerichtet oder stattdessen direkt deren Wert 0 eingesetzt werden.

Entsprechend muss der Code im Button nun zwischen VBA-Funktionen und Abfragen unterscheiden können, wie Sie in Listing 12 sehen. Durch den Parameter -1, der dem Wert von True entspricht, wird beim Aufruf einer solchen Funktion der darin enthaltene Aktionsteil aufgerufen. Der Rückgabewert wird dabei ignoriert.

Private Sub btnFormular_Click()
Dim qryAktuell As QueryDef
Dim strDescript As String
Dim strFormular As String
Dim strTabelle As String
Dim strFeld As String
Select Case Me.QQuelle.Value
Case "VBA"
'Funktion mit Parameter TRUE ausführen
Eval "fnc" & Me.QTyp.Value & Me.QName & "(-1)"
Case "Query"
'Eigenschaften der Abfrage auslesen
Set qryAktuell = CurrentDb.QueryDefs( _
"qry" & Me.QTyp.Value & Me.QName.Value)
'… [Code wie in Listing 9]
'Fehlermeldung
MsgBox "Formularname für " & Me.QName.Value & " fehlt!", _
vbCritical
End If
End Select
End Sub