Access Tools

VBA Code für Access

Access lässt sich mittels VBA optimieen. Wiederkehrende Aufgaben oder Handgriffe können optimiert und automatisiert werden. Einige dieser Tools und Funktionen haben wir zur Verfügung gestellt.

Alle zur Verfügung gestellten Materialien sind nach bestem Wissen zusammengestellt worden, dennoch können wir für Fehler oder die Funktion keine Verantwortung übernehmen.

Systemumgebung ausblenden / einblenden

Steuerung, ob das Access Fenster angezeigt werden soll oder nicht. Es sollte immer eine Option für die Wiederanzeige implementieren werden. Funktionen entsprechend in der Anwendung via Button verfügbar machen. Code als Modul z. B. SetWindow speichern.

Mehr…

Option Compare Database

Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Const SW_MINIMIZE = 6
Private Const SW_MAXIMIZE = 3
Private Const SW_RESTORE = 9

Public Function MinimizeAccess()
ShowWindow Application.hWndAccessApp, SW_MINIMIZE
End Function

Public Function MaximizeAccess()
ShowWindow Application.hWndAccessApp, SW_MAXIMIZE
End Function

Public Function RestoreAccess()
ShowWindow Application.hWndAccessApp, SW_RESTORE
End Function

Weniger…

Einzelnen Tabellenwert auslesen

Die Funktion liefert einen Tabellenwert (Feld) aus ein Tabelle zurück. Die Selektion erfolgt über ein SQL Statement.

Mehr…

Function getSingleValue(qryStrg As String, returnField As String) As Variant
On Error GoTo ErrorExit
' Funktion ermittelt einen einzelnen Feldwert - das SQL Statement muss so
' aufgebaut sein, dass nur ein Wert ermittelt wird

Dim outputTxt As Variant

Dim db As DAO.Database
Dim rc As DAO.Recordset

Set db = CurrentDb
Set rc = db.OpenRecordset(qryStrg, dbOpenSnapshot)

outputTxt = ""

With rc
outputTxt = .Fields(returnField)
End With

db.Close
' keine Fehlerbehandlung bei Null, da Variant - nachfolgende Sub/Function müssen das Handling übernehmen
getSingleValue = outputTxt

Exit Function

ErrorExit:
' Null als Rückgabewert nicht als Fehlermeldung ausgeben
If Err <> 3021 Then MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next

End Function

Weniger…

Umgebung beim starten eines Formulars ausblenden

Code in (Start)Formular übernehmen, dann wird Access mit Formularstart ausgeblendet

Mehr…

Private Sub Form_Open(Cancel As Integer)
On Error GoTo ErrorExit

Dim Para_1 As String ' fld_ST_ID
Dim Para_2 As String ' Reserve
Dim Para_3 As String ' Reserve

'****************************
' Access Umfeld ausblenden
'****************************
Dim hWindow As Long
Dim nResult As Long
Dim nCmdShow As Long
hWindow = Application.hWndAccessApp
nCmdShow = SW_HIDE
nResult = ShowWindow(ByVal hWindow, ByVal nCmdShow)
Call ShowWindow(Me.hwnd, SW_NORMAL)
'****************************

Exit Sub
ErrorExit:
If Err = 94 Then Exit Sub
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next

End Sub

Weniger…

Prüfen ob oder viele Einträge in einer Tabelle vorhanden sind

Die Funktion RecExist ermittelt, ob in einer Tabelle Einträge vorhanden sind und die Funktion RecCount wie viele Einträge in einer Tabelle existieren.

Mehr…

Function RecCount(sqlStrg As String) As Integer
On Error GoTo ErrorExit
' Funktion prüft, ob Datensätze vorhanden sind
' True = Datensätze vorhanden
' False = keine Datensätze vorhanden

' Microsoft DAO 3.5 Object Library muss in Extras, Verweise aktiviert sein
Dim db As DAO.Database
Dim rc As DAO.Recordset
Dim recNo As Integer

Set db = CurrentDb
Set rc = db.OpenRecordset(sqlStrg, dbReadOnly)

' Auszählung per Schleife, da RecordCount nicht funktioniert
recNo = 0

Do Until rc.EOF
recNo = recNo + 1
rc.MoveNext
Loop
rc.Close

RecCount = recNo

Exit Function
ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next

End Function

Function RecExist(sqlStrg As String) As Boolean
On Error GoTo ErrorExit
' Funktion prüft, ob Datensätze vorhanden sind
' True = Datensätze vorhanden
' False = keine Datensätze vorhanden

' Microsoft DAO 3.5 Object Library muss in Extras, Verweise aktiviert sein
Dim db As DAO.Database
Dim rc As DAO.Recordset

Set db = CurrentDb
Set rc = db.OpenRecordset(sqlStrg, dbOpenDynaset, dbSeeChanges, dbReadOnly)

If rc.RecordCount <> 0 Then
db.Close
IfRecExist = True
Else
db.Close
IfRecExist = False
End If

Exit Function
ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next

End Function

Weniger…

Applikationspfad auslesen

Die Funktion ermittelt den aktuellen Pfad der Applikation und gibt diesen zur weiteren Bearbeitung zurück.

Mehr…

Public Function ApplicationPath() As String
' ermittelt den Pfad der aktuellen Access Anwendung
On Error Resume Next

Dim sPath As String

sPath = CurrentDb.Name
While Right$(sPath, 1) <> "\"
sPath = Left$(sPath, Len(sPath) - 1)
Wend
ApplicationPath = sPath

Exit Function

ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Function

Weniger…

Applikationsnamen auslesen

Die Funktion ermittelt den Namen der aktuellen Applikation und stellt ihn zur weiteren Verarbeitung zur Verfügung.

Mehr…

Public Function ApplicationName(Optional WithExtension As Boolean = True) As String
' Ermittelt den Namen der aktuellen Access Anwendung
' Rückgabe mit oder ohne Dateinamenserweiterung

On Error Resume Next

Dim sRes As String
Dim n As Long

sRes = CurrentDb.Name
n = InStrRev(CStr(sRes), "\")

If n > 0 Then
sRes = Mid(sRes, n + 1)
End If

If Not WithExtension Then
n = InStrRev(sRes, ".")
If n > 0 Then
sRes = Left(sRes, n - 1)
End If
End If
ApplicationName = sRes

Exit Function

ErrorExit:
MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Function

Weniger…

Objekte der Datenbank dokumentieren

Die Funktionen dokumentieren im Zusammenspiel die in der Datenbank verwendeten Objekte.

Mehr…

Option Compare Database

Option Explicit

Sub ObjWrite(v_Objekte As String, v_ObjName As String, v_ObjDescription As String)

On Error GoTo ErrorExit

Dim dbs As DAO.Database

Dim tdf As DAO.TableDef

Dim rst As DAO.Recordset

Set dbs = CurrentDb

Set tdf = dbs.TableDefs("doc_Objekte_Pgm")

Set rst = dbs.OpenRecordset("doc_Objekte_Pgm")

With rst

.AddNew

![ObjType] = v_Objekte

![ObjName] = v_ObjName

![ObjDescription] = v_ObjDescription

.Update

End With

dbs.Close

Set dbs = Nothing

Exit Sub

ErrorExit:

MsgBox Error(Err), vbInformation, "ObJWrite: Fehlermeldung (" & LTrim(Str(Err)) & ")"

Resume Next

End Sub

Sub ObjTblAnlegen()

On Error GoTo ErrorExit

Dim dbs As Database

Dim tdf As TableDef

Dim fld As Field

Dim tmpI As Integer

Set dbs = CurrentDb

Set tdf = dbs.CreateTableDef("doc_Objekte_Pgm")

With tdf

.Fields.Append .CreateField("ObjType", dbText, 150)

.Fields.Append .CreateField("ObjName", dbText, 50)

.Fields.Append .CreateField("ObjDescription", dbText, 250)

End With

dbs.TableDefs.Append tdf

dbs.Close

Set dbs = Nothing

Exit Sub

ErrorExit:

If Err = 3010 Then

DoCmd.DeleteObject acTable, "doc_Objekte_Pgm"

Resume

End If

End Sub

Sub listObjects(ObjectType As String)

On Error GoTo ErrorExit

Dim Obj As Object

' ObjectType: qry, tbl, ber, mod, frm

' ObjWrite(v_Objekte As String, v_ObjName As String, v_ObjDescription As String)

Select Case ObjectType

Case "qry"

For Each Obj In CurrentDb.QueryDefs

If InStr(Obj.Name, "~") = 0 Then

' Debug.Print Obj.Name, Obj.Properties("Description")

ObjWrite "Abfrage", Obj.Name, Obj.Properties("Description")

End If

Next Obj

Case "tbl"

For Each Obj In CurrentDb.TableDefs

If InStr(Obj.Name, "MSys") = 0 And InStr(Obj.Name, "~") = 0 And InStr(Obj.Name, "doc") = 0 And InStr(Obj.Name, "tmp") = 0 Then

' Debug.Print Obj.Name, Obj.Properties("Description")

ObjWrite "Tabelle", Obj.Name, Obj.Properties("Description")

End If

Next Obj

Case "ber"

For Each Obj In CurrentProject.AllReports

If InStr(Obj.Name, "doc") = 0 Then

' Debug.Print Obj.Name, CurrentDb.Containers("Reports").Documents(Obj.Name).Properties("Description")

ObjWrite "Report", Obj.Name, CurrentDb.Containers("Reports").Documents(Obj.Name).Properties("Description")

End If

Next Obj

Case "mod"

For Each Obj In CurrentProject.AllModules

If InStr(Obj.Name, "doc") = 0 Then

' Debug.Print Obj.Name, CurrentDb.Containers("Modules").Documents(Obj.Name).Properties("Description")

ObjWrite "Modul", Obj.Name, CurrentDb.Containers("Modules").Documents(Obj.Name).Properties("Description")

End If

Next Obj

Case "frm"

For Each Obj In CurrentProject.AllForms

' Debug.Print Obj.Name, CurrentDb.Containers("Forms").Documents(Obj.Name).Properties("Description")

ObjWrite "Formular", Obj.Name, CurrentDb.Containers("Forms").Documents(Obj.Name).Properties("Description")

Next Obj

Case Else

MsgBox "Falscher Parameter", vbCritical + vbOKOnly, "Fehler"

End Select

Exit Sub

ErrorExit:

If Err <> 3270 Then

MsgBox Error(Err), vbInformation, "ListObjects Fehlermeldung (" & LTrim(Str(Err)) & ")"

Else

ObjWrite ObjectType, Obj.Name, "ERFASSEN"

End If

Resume Next

End Sub

Sub runAll()

On Error GoTo ErrorExit

ObjTblAnlegen

listObjects "qry"

listObjects "tbl"

listObjects "ber"

listObjects "mod"

listObjects "frm"

Exit Sub

ErrorExit:

MsgBox Error(Err), vbInformation, "runAll Fehlermeldung (" & LTrim(Str(Err)) & ")"

Resume Next

End Sub

Sub UpdateMenueTbl()

On Error GoTo ErrorExit

Dim sqlStrg As String

sqlStrg = "UPDATE tbl_Sys_Menue INNER JOIN doc_Objekte_Pgm ON tbl_Sys_Menue.fld_menue_Value = "

sqlStrg = sqlStrg & "doc_Objekte_Pgm.ObjName SET tbl_Sys_Menue.fld_menue_Beschreibung = [doc_objekte_pgm].[ObjDescription] "

sqlStrg = sqlStrg & "WHERE (((tbl_Sys_Menue.fld_menue_Beschreibung) Is Null)) OR (((tbl_Sys_Menue.fld_menue_Beschreibung)=''));"

DoCmd.SetWarnings False

DoCmd.RunSQL sqlStrg

DoCmd.SetWarnings True

Exit Sub

ErrorExit:

MsgBox Error(Err), vbInformation, "runAll Fehlermeldung (" & LTrim(Str(Err)) & ")"

Resume Next

End Sub

Sub UpdateMenue()

On Error GoTo ErrorExit

runAll

UpdateMenueTbl

MsgBox "Kommentare wurden aus den Objekteigenschaften in die leeren Anmerkungen übernommen!", vbOKOnly, "Hinweis"

Exit Sub

ErrorExit:

MsgBox Error(Err), vbInformation, "runAll Fehlermeldung (" & LTrim(Str(Err)) & ")"

Resume Next

End Sub

Weniger…

Tabellen der Datenbank dokumentieren

Die Funktionen dokumentieren im Zusammenspiel die in der Datenbank verwendeten Tabellen.

Mehr…

Option Compare Database

Option Explicit

Function FieldType(intType As Integer) As String

On Error GoTo ErrorExit

Dim F_Type As String

Select Case intType

Case dbBoolean

F_Type = "Boolean"

Case dbByte

F_Type = "Byte"

Case dbInteger

F_Type = "Integer"

Case dbLong

F_Type = "Long"

Case dbCurrency

F_Type = "Currency"

Case dbSingle

F_Type = "Single"

Case dbDouble

F_Type = "Double"

Case dbDate

F_Type = "Date"

Case dbText

F_Type = "Text"

Case dbLongBinary

F_Type = "LongBinary"

Case dbMemo

F_Type = "Memo"

Case dbGUID

F_Type = "GUID"

Case Else

F_Type = "nn or Variant"

End Select

' FieldType = "db" + F_Type als Systemvariable

FieldType = F_Type

Exit Function

ErrorExit:

MsgBox Error(Err), vbInformation, "FieldType: Fehlermeldung (" & LTrim(Str(Err)) & ")"

Resume Next

End Function

Sub ListFeld(v_tblName As String, v_Index As Boolean)

On Error GoTo ErrExit

Dim dbs As DAO.Database

Dim tdf As DAO.TableDef

Dim fld As DAO.Field

Dim tmpI As Integer

Dim bufferTbl As String

Dim bufferFld As String

Set dbs = CurrentDb

Set tdf = dbs.TableDefs(v_tblName)

For tmpI = 0 To tdf.Fields.Count - 1

bufferTbl = ""

bufferFld = ""

Set fld = tdf.Fields(tdf.Fields(tmpI).Name)

bufferTbl = tdf.Properties("Description").Value

If Len(bufferTbl) = 0 Then bufferTbl = " "

bufferFld = fld.Properties("Description").Value

If Len(bufferFld) = 0 Then bufferFld = " "

tblAnalyse v_Index, dbs.Name, tdf.Name, bufferTbl, tdf.Fields(tmpI).Name, FieldType(tdf.Fields(tmpI).Type), tdf.Fields(tmpI).Size, tmpI + 1, bufferFld

Next tmpI

Set dbs = Nothing

Exit Sub

ErrExit:

'Debug.Print Error(Err), Err, "ListFeld"

Resume Next

End Sub

Sub tblAnalyse(v_Key As Boolean, v_DB As String, v_tbl As String, v_tblInfo As String, v_field As String, v_Typ As String, v_size As String, v_no As Integer, v_info As String)

On Error GoTo ErrorExit

Dim dbs As DAO.Database

Dim tdf As DAO.TableDef

Dim rst As DAO.Recordset

Set dbs = CurrentDb

Set tdf = dbs.TableDefs("doc_Struktur_Pgm")

Set rst = dbs.OpenRecordset("doc_Struktur_Pgm")

If v_Key = False Then

' Keys und Foreign Keys werden nicht übergeben

If InStr(UCase(v_field), "_ID") > 0 Then Exit Sub

End If

With rst

.AddNew

![db] = v_DB

![Tbl] = v_tbl

![TblInfo] = v_tblInfo

![Field] = v_field

![Typ] = v_Typ

![Size] = v_size

![No] = v_no

![Info] = v_info

.Update

End With

dbs.Close

Set dbs = Nothing

Exit Sub

ErrorExit:

MsgBox Error(Err), vbInformation, "tblAnalyse: Fehlermeldung (" & LTrim(Str(Err)) & ")"

Resume Next

End Sub

Sub tblAnlegen()

On Error GoTo ErrorExit

Dim dbs As Database

Dim tdf As TableDef

Dim fld As Field

Dim tmpI As Integer

Set dbs = CurrentDb

Set tdf = dbs.CreateTableDef("doc_Struktur_Pgm")

With tdf

.Fields.Append .CreateField("DB", dbText, 150)

.Fields.Append .CreateField("Tbl", dbText, 50)

.Fields.Append .CreateField("TblInfo", dbText, 150)

.Fields.Append .CreateField("Field", dbText, 50)

.Fields.Append .CreateField("Typ", dbText, 50)

.Fields.Append .CreateField("Size", dbText, 50)

.Fields.Append .CreateField("No", dbInteger)

.Fields.Append .CreateField("Info", dbText, 250)

End With

dbs.TableDefs.Append tdf

dbs.Close

Set dbs = Nothing

Exit Sub

ErrorExit:

If Err = 3010 Then

DoCmd.DeleteObject acTable, "doc_Struktur_Pgm"

Resume

End If

End Sub

Sub gesamterAblauf()

On Error GoTo ErrorExit

Dim dbs As Database

Dim tmpI As Integer

tblAnlegen

Set dbs = CurrentDb

For tmpI = 0 To dbs.TableDefs.Count - 1

If dbs.TableDefs(tmpI).Attributes = 0 Then

If InStr(dbs.TableDefs(tmpI).Name, "doc_") = 0 Then

Debug.Print dbs.TableDefs(tmpI).Name

ListFeld dbs.TableDefs(tmpI).Name, True ' true = es werden auch die ID Felder aufgelistet

End If

Exit Sub

ErrorExit:

MsgBox Error(Err), vbInformation, "Fehlermeldung (" & LTrim(Str(Err)) & ")"

Resume Next

End Sub

Weniger…