Microsoft Access VBA-Tools - Institut für … Access VBA-Tools Otmar Haring Seite 2...

Pädagogisches Institut des Bundes

in Oberösterreich

Microsoft Access VBA-Tools

Otmar Haring


Otmar Haring Seite 2

Inhaltsverzeichnis 1. Bericht per Mail versenden ................................................................................................ 3

Voreinstellungen und Voraussetzungen............................................................................................. 3 Snapshot-Dateien ............................................................................................................................... 3 Das Versendeformular........................................................................................................................ 4 Erweiterung: Dateiformat des Attachments auswählen ..................................................................... 7 Adresseneingabe mit Hilfe eines weiteren Formulars........................................................................ 8

2. Druck-Manager ................................................................................................................. 17 Voreinstellungen und Voraussetzungen........................................................................................... 17 Windows-Funktionen: GetProfileString, GetPrivateProfileString................................................... 18 Funktionen in Access 97 und 2000 .................................................................................................. 19

Funktion „DruckerAktivSetzen“............................................................................................................. 19 Funktionen „AktivenDruckerErmitteln“ und „AktiveDruckerListe“...................................................... 24

Funktionen in Access XP ................................................................................................................. 26 Beispielanwendung für die Druckerauswahl.................................................................................... 28

3. Funktionen rund um das Datum...................................................................................... 30 Geburtstagslisten .............................................................................................................................. 30 Geburtstage in einem bestimmten Zeitraum suchen ........................................................................ 32 Gesetzliche und kirchliche Feiertage ............................................................................................... 32

Fixe Feiertage ......................................................................................................................................... 32 Bewegliche Feiertage.............................................................................................................................. 33

Monatskalender mit Feiertagen........................................................................................................ 37 Jahreskalender .................................................................................................................................. 38

Das Formular .......................................................................................................................................... 38 Die Abfrage............................................................................................................................................. 39 Der Bericht.............................................................................................................................................. 40

4. Euro-Rechner..................................................................................................................... 41 5. Benutzerdefinierte Fortschrittsleiste ............................................................................... 43 6. Automatische Einbindung externer Tabellen ................................................................. 49 7. Kunden- und Rechnungsverwaltung ............................................................................... 54

Datenbankaufbau.............................................................................................................................. 54 Kundenverwaltung ........................................................................................................................... 55 Reparaturtexte verwalten.................................................................................................................. 59 Etikettenausdrucke von Kundenadressen......................................................................................... 60 Rechnungsformular .......................................................................................................................... 64 Rechnungen stornieren..................................................................................................................... 70 Kunden samt Rechnungen suchen.................................................................................................... 73 Zahlungseingänge erfassen .............................................................................................................. 75 Anwendung starten........................................................................................................................... 77



1. Bericht per Mail versenden Voreinstellungen und Voraussetzungen

Der Versand der Emails erfolgt über das installierte Standard-Emailprogramm. Das kann z.B. Outlook Express oder Microsoft Outlook sein.

Der Einbau des Moduls in andere Anwendungen ist sehr einfach. Es müssen lediglich folgende Objekte importiert werden:

Tabellen: - tblTmp_Email_An Alle diese drei Tabellen enthalten nur - tblTmp_Email_Cc das Feld „eMail”, welches als „Text“ - tblTmp_Email_Bcc mit der Feldgröße „255” definiert ist.

Abfrage: - qryMailadressen Beschreibung auf Seite 8.

Formulare: - frmEmail - frmEmail-Auswahl

Damit der gesamte Programmcode ordnungsgemäß funktioniert, müssen folgende Verweise aktiviert sein:

Für Access 97: - Visual Basic For Applications - Microsoft Access 8.0 Object Library - Microsoft DAO 3.51 Object Library (oder höher) - Microsoft Outlook 9.0 Object Library

Für Access 2000: - Visual Basic For Applications - Microsoft Access 9.0 Object Library - Microsoft DAO 3.6 Object Library (oder höher) - OLE Automation - Microsoft Visual Basic for Applications Extensibility 5.3 - Microsoft Outlook 10.0 Object Library

Snapshot-Dateien Bericht-Snapshots können mit jeder Access-Version erstellt werden. In der Layout-Vorschau des Berichts kann dies mit dem Menüpunkt „Datei / Exportieren“ durch-geführt werden. Daraufhin wird eine Datei mit der Endung „.snp“ erzeugt. Diese Datei kann mit dem Snapshot-Viewer geöffnet, angezeigt oder gedruckt werden.

Der Snapshot-Viewer wird bei der Standardinstallation von Access bzw. Office automatisch installiert, kann jedoch auch ohne Access-Lizenz von der Microsoft-Webseite heruntergeladen werden. Die Download-Adressen für Access 97 bzw. Access 2000 lauten: http://office.microsoft.com/downloads/9798/snpvw80.aspx http://office.microsoft.com/downloads/2000/Snpvw90.aspx

Genauso wie PDF-Dateien sind Snapshot-Dateien nachträglich nicht vom Empfänger veränderbar. PDF-Dateien können zwar mit Adobe Acrobat geöffnet und unter Umständen auch verändert gespeichert werden, dies lässt sich jedoch durch entsprechende Signatur verhindern. Snapshot-Dateien können nachträglich mit keiner verfügbaren Software verändert werden; ein Schutz durch Signaturen ist daher weder möglich noch notwendig.

Mit Hilfe eines ActiveX-Steuerelements, das mit dem Snapshot-Viewer installiert wird, kann eine Snapshot-Datei auch in eine Webseite eingebettet werden. Dies ist



entweder über einen <object>-Tag auf der HTML-Seite oder (noch viel einfacher) über einen Link auf die SNP-Datei ermöglicht.

Damit der Browser die SNP-Datei allerdings öffnen kann, sind folgende Voraussetzungen erforderlich:

• Der Snapshot-Viewer muss auf dem Rechner des Betrachters installiert sein • Als Browser muss der Internet Explorer 3.0 oder höher verwendet werden

Das Einbinden über den <object>-Tag könnte folgendes Aussehen haben:

<html> <head> </head> <body> <h1>Eine eingebettete Snapshot-Datei</h1> <object ID=“SnapshotViewer“ WIDTH=640 HEIGHT=480 CLASSID=”CLSID:F0E42D60-368C-11D0-AD81-00A0C90DC8D9”> <PARAM NAME=”_ExtentX” VALUE=”16722”> <PARAM NAME=”_ExtentY” VALUE=”11774”> <PARAM NAME=”_Version” VALUE=”65536”> <PARAM NAME=”SnapshotPath” VALUE=”test.snp”> <PARAM NAME=”Zoom” VALUE=”1”> <PARAM NAME=”AllowContextMenu” VALUE=”-1”> <PARAM NAME=”ShowNavigationButtons” VALUE=”-1”> </object> </body> </html>

Über die Parameter “AllowContextMenu” und “ShowNavigationButtons” kann das Aussehen des Steuerelements festgelegt werden

Anders als beim Konvertieren in eine PDF-Datei besteht beim Erstellen einer Snapshot-Datei nicht die Möglichkeit, einzelne Seiten zu speichern. Um beispielsweise aus einem mehrseitigen Bericht für jede Seite eine eigene Datei zu erzeugen, muss zuvor eine Abfrage erstellt werden, die genau diese Seite als Ergebnis liefert.

Das Versendeformular Mit Hilfe dieses einfachen Formulars ist es möglich, einen Access-Bericht an mehrere Personen per Mail zu versenden. Der Bericht wird dazu in das Snapshot-Format (*.snp) konvertiert und als Attachment an das Mail angefügt.



Hinter diesem Formular verbirgt sich der folgende Programmcode:

Option Compare Database Option Explicit Private Sub cmdClose_Click() On Error GoTo Err_cmdClose_Click DoCmd.Close Exit_cmdClose_Click: Exit Sub Err_cmdClose_Click: MsgBox Err.Description Resume Exit_cmdClose_Click End Sub Private Sub cmdSend_Click() On Error GoTo fehler Dim RepName As String Dim Attachment As String Dim Tempverz As String ' Adressen prüfen If (IsNull(Me!txtAn) Or Me!txtAn = "") And (IsNull(Me!txtCc) Or _ Me!txtCc = "") And (IsNull(Me!txtBcc) Or Me!txtBcc = "") Then MsgBox "In den Feldern " & Chr(34) & "An" & Chr(34) & ", " & _ Chr(34) & "Cc" & Chr(34) & " oder " & Chr(34) & "Bcc" & _ Chr(34) & " muss mindestens " & "eine Empfängeradresse " & _ "stehen!", vbOKOnly + vbExclamation, "Fehler" DoCmd.GoToControl "txtAn" Exit Sub Else If IsNull(Me!txtAn) Then Me!txtAn = "" If IsNull(Me!txtCc) Then Me!txtCc = "" If IsNull(Me!txtBcc) Then Me!txtBcc = "" End If ' Betreff prüfen If IsNull(Me!txtBetreff) Or Me!txtBetreff = "" Then If MsgBox("Sie haben keinen Betreff eingegeben." & vbCrLf & _ "Möchten Sie das Mail " & "trotzdem versenden?", vbYesNo + _ vbQuestion, "Fehler") = vbNo Then DoCmd.GoToControl "txtBetreff" Exit Sub Else Me!txtBetreff = "" End If End If ' Mailtext prüfen If IsNull(Me!txtMailinhalt) Or Me!txtMailinhalt = "" Then If MsgBox("Sie haben keinen Mailinhalt angegeben." & vbCrLf & _ "Möchten Sie das Mail " & "trotzdem versenden?", vbYesNo + _ vbQuestion, "Fehler") = vbNo Then DoCmd.GoToControl "txtMailinhalt" Exit Sub Else Me!txtMailinhalt = "" End If End If



' Attachment prüfen If IsNull(Me!cboAttachment) Or Me!cboAttachment = "" Then MsgBox "Es wurde kein Attachment zum Versenden angegebenen." & _ vbCrLf & "Bitte wählen Sie ein Objekt aus!", vbOKOnly + _ vbExclamation, "Fehler" DoCmd.GoToControl "cboAttachment" Exit Sub Else RepName = Me!cboAttachment End If ' Temp-Verzeichnis festlegen ' ( wird Temp nicht gefunden wird in die Root gespeichert) Tempverz = Environ("Tmp") If Tempverz = "" Then Tempverz = "c:" Attachment = Tempverz & "\" & RepName & ".snp" ' Reports als SNP ins Temp-Verzeichnis speichern DoCmd.OutputTo acReport, RepName, acFormatSNP, Attachment, False, "" ' SNP-Reports über Outlookobject wegmailen OutlookMailSenden (Attachment) ' SNP-Reports löschen Kill Attachment ende: Exit Sub fehler: MsgBox Err.Description Resume ende End Sub Sub OutlookMailSenden(Anhang As String) On Error GoTo fehler Dim objOutlook As Outlook.Application Dim objOutlookMsg As Outlook.MailItem Dim objOutlookAttach As Outlook.Attachment ' Create the Outlook session. Set objOutlook = CreateObject("Outlook.Application") ' Create the message. Set objOutlookMsg = objOutlook.CreateItem(olMailItem) With objOutlookMsg ' Adressen einfügen .To = Me!txtAn .CC = Me!txtCc .BCC = Me!txtBcc ' Betreff einfügen .Subject = Me!txtBetreff ' Mailinhalt einfügen .Body = Me!txtMailinhalt ' Anhang einfügen If Not IsMissing(Anhang) Then Set objOutlookAttach = .Attachments.Add(Anhang) End If ' Senden oder Anzeigen '.Display .Send End With



Set objOutlook = Nothing ende: Exit Sub fehler: MsgBox Err.Description, 16, "Fehler" Resume ende End Sub Private Sub Form_Open(Cancel As Integer) ' Type definiert den Objekttyp: ' 1 = Tabelle ' 5 = Abfrage ' -32768 = Formular ' -32764 = Bericht ' -32761 = Modul ' ' Flags definiert die Art des Objekts ' 0 = selbsterstelltes Objekt Me!cboAttachment.RowSource = "Select MSysObjects.Name From " & _ MSysObjects Where Type = -32764 And Flags = 0) Order by Name;" End Sub

Erweiterung: Dateiformat des Attachments auswählen In diesem Fenster wird dem Anwender zusätzlich die Möglichkeit gegeben, das Format des Attachments zu bestimmen:

Die Änderungen bzw. Ergänzungen zum vorherigen Beispiel sind fett gedruckt:

Private Sub cboAttachment_AfterUpdate() If IsNull(Me!cboAttachment) Or Me!cboAttachment = "" Then Me!cboFormat.Visible = False Else Me!cboFormat.Visible = True End If If IsNull(Me!cboFormat) Or Me!cboFormat = "" Then Me!cboFormat = "SNP" End If End Sub



Private Sub cmdSend_Click() : : : : : ' Temp-Verzeichnis festlegen ' ( wird Temp nicht gefunden wird in die Root gespeichert) Tempverz = Environ("Tmp") If Tempverz = "" Then Tempverz = "c:" Attachment = Tempverz & "\" & RepName ' Reports ins Temp-Verzeichnis speichern Select Case Me!cboFormat Case "SNP" Attachment = Attachment & ".snp" DoCmd.OutputTo acReport, RepName, acFormatSNP, Attachment, _ False, "" Case "HTML" Attachment = Attachment & ".htm" DoCmd.OutputTo acReport, RepName, acFormatHTML, Attachment, _ False, "" Case "RTF" Attachment = Attachment & ".rtf" DoCmd.OutputTo acReport, RepName, acFormatRTF, Attachment, _ False, "" Case "TXT" Attachment = Attachment & ".txt" DoCmd.OutputTo acReport, RepName, acFormatTXT, Attachment, _ False, "" Case "XLS" Attachment = Attachment & ".xls" DoCmd.OutputTo acReport, RepName, acFormatXLS, Attachment, _ False, "" End Select ' Reports über Outlookobject wegMailen OutlookMailSenden (Attachment) ' Reports löschen Kill Attachment ende: Exit Sub fehler: MsgBox Err.Description Resume ende End Sub

Adresseneingabe mit Hilfe eines weiteren Formulars Diese Erweiterung ermöglicht die Eingabe der Adressen in einem eigenen Formular. Dabei wird eine Abfrage mit dem Namen „qryMailadressen“ als Datenquelle verwendet. Diese Abfrage muss die Felder „Empfänger“ und „eMail“ beinhalten.

Die Daten aus dieser Abfrage werden anschließend in einem Listenfeld aufgelistet. Aus diesem Listenfeld können die Mailadressen den verschiedenen Empfängertypen („An“, „Cc“, „Bcc“) zugewiesen werden.



Option Compare Database Option Explicit Private Sub cmdAn_Click() On Error GoTo Err_cmdAn_Click Dim rs As Recordset ' Überprüfen, ob eine Auswahl getroffen wurde If ((IsNull(Me![lstAuswahl])) Or (Me![lstAuswahl] = "")) Then Beep Exit Sub End If ' Überprüfen, ob der Empfänger bereits einmal ausgewählt wurde If (DLookup("[Email]", "tblTmp_Email_an", "[Email]='" & _ Me![lstAuswahl] & "'")) = Me![lstAuswahl] Then Exit Sub End If If (DLookup("[Email]", "tblTmp_Email_cc", "[Email]='" & _ Me![lstAuswahl] & "'")) = Me![lstAuswahl] Then Exit Sub End If If (DLookup("[Email]", "tblTmp_Email_bcc", "[Email]='" & _ Me![lstAuswahl] & "'")) = Me![lstAuswahl] Then Exit Sub End If ' Eintragen des Empfängers in eine temporäre Tabelle Set rs = CurrentDb.OpenRecordset("tblTmp_Email_an", dbOpenDynaset, _ dbAppendOnly) With rs .AddNew ![Email] = Me![lstAuswahl] .Update End With rs.Close ' Übernehmen des Empfängers in das Listenfeld Me![lstAn] = Me![lstAuswahl] Me![lstAn].Requery Exit_cmdAn_Click: Exit Sub



Err_cmdAn_Click: MsgBox Err.Description Resume Exit_cmdAn_Click End Sub Private Sub cmdAnDelete_Click() On Error GoTo Err_cmdAnDelete_Click Dim rs As Recordset Dim Kriterien As String Dim Help ' Überprüfen, ob eine Auswahl getroffen wurde If ((IsNull(Me![lstAn])) Or (Me![lstAn] = "")) Then Beep Exit Sub End If Help = Me![lstAn] ' Löschen des Empfängers aus der temporären Tabelle Set rs = CurrentDb.OpenRecordset("tblTmp_Email_an", dbOpenDynaset) Kriterien = "[Email] = '" & Me![lstAn] & "'" rs.FindFirst Kriterien If Not rs.NoMatch Then rs.Delete Me![lstAuswahl] = Help End If rs.Close ' Anzeige akualisieren Me![lstAn].Requery Me![lstAuswahl] = Help Exit_cmdAnDelete_Click: Exit Sub Err_cmdAnDelete_Click: MsgBox Err.Description Resume Exit_cmdAnDelete_Click End Sub Private Sub cmdBcc_Click() On Error GoTo Err_cmdBcc_Click Dim rs As Recordset ' Überprüfen, ob eine Auswahl getroffen wurde If ((IsNull(Me![lstAuswahl])) Or (Me![lstAuswahl] = "")) Then Beep Exit Sub End If ' Überprüfen, ob der Empfänger bereits einmal ausgewählt wurde If (DLookup("[Email]", "tblTmp_Email_an", "[Email]='" & _ Me![lstAuswahl] & "'")) = Me![lstAuswahl] Then Exit Sub End If If (DLookup("[Email]", "tblTmp_Email_cc", "[Email]='" & _ Me![lstAuswahl] & "'")) = Me![lstAuswahl] Then Exit Sub End If If (DLookup("[Email]", "tblTmp_Email_bcc", "[Email]='" & _ Me![lstAuswahl] & "'")) = Me![lstAuswahl] Then Exit Sub End If ' Eintragen des Empfängers in eine temporäre Tabelle Set rs = CurrentDb.OpenRecordset("tblTmp_Email_Bcc", dbOpenDynaset, _ dbAppendOnly)



With rs .AddNew ![Email] = Me![lstAuswahl] .Update End With rs.Close ' Übernehmen des Empfängers in das Listenfeld Me![lstBCC] = Me![lstAuswahl] Me![lstBCC].Requery Exit_cmdBcc_Click: Exit Sub Err_cmdBcc_Click: MsgBox Err.Description Resume Exit_cmdBcc_Click End Sub Private Sub cmdBccDelete_Click() On Error GoTo Err_cmdBccDelete_Click Dim rs As Recordset Dim Kriterien As String Dim Help ' Überprüfen, ob eine Auswahl getroffen wurde If ((IsNull(Me![lstBCC])) Or (Me![lstBCC] = "")) Then Beep Exit Sub End If Help = Me![lstBCC] ' Löschen des Empfängers aus der temporären Tabelle Set rs = CurrentDb.OpenRecordset("tblTmp_Email_Bcc", dbOpenDynaset) Kriterien = "[Email] = '" & Me![lstBCC] & "'" rs.FindFirst Kriterien If Not rs.NoMatch Then rs.Delete Me![lstAuswahl] = Help End If rs.Close ' Anzeige akualisieren Me![lstBCC].Requery Me![lstAuswahl] = Help Exit_cmdBccDelete_Click: Exit Sub Err_cmdBccDelete_Click: MsgBox Err.Description Resume Exit_cmdBccDelete_Click End Sub Private Sub cmdCc_Click() On Error GoTo Err_cmdCc_Click Dim rs As Recordset ' Überprüfen, ob eine Auswahl getroffen wurde If ((IsNull(Me![lstAuswahl])) Or (Me![lstAuswahl] = "")) Then Beep Exit Sub End If



' Überprüfen, ob der Empfänger bereits einmal ausgewählt wurde If (DLookup("[Email]", "tblTmp_Email_an", "[Email]='" & _ Me![lstAuswahl] & "'")) = Me![lstAuswahl] Then Exit Sub End If If (DLookup("[Email]", "tblTmp_Email_cc", "[Email]='" & _ Me![lstAuswahl] & "'")) = Me![lstAuswahl] Then Exit Sub End If If (DLookup("[Email]", "tblTmp_Email_bcc", "[Email]='" & _ Me![lstAuswahl] & "'")) = Me![lstAuswahl] Then Exit Sub End If ' Eintragen des Empfängers in eine temporäre Tabelle Set rs = CurrentDb.OpenRecordset("tblTmp_Email_Cc", dbOpenDynaset, _ dbAppendOnly) With rs .AddNew ![Email] = Me![lstAuswahl] .Update End With rs.Close ' Übernehmen des Empfängers in das Listenfeld Me![lstCC] = Me![lstAuswahl] Me![lstCC].Requery Exit_cmdCc_Click: Exit Sub Err_cmdCc_Click: MsgBox Err.Description Resume Exit_cmdCc_Click End Sub Private Sub cmdCcDelete_Click() On Error GoTo Err_cmdCcDelete_Click Dim rs As Recordset Dim Kriterien As String Dim Help ' Überprüfen, ob eine Auswahl getroffen wurde If ((IsNull(Me![lstCC])) Or (Me![lstCC] = "")) Then Beep Exit Sub End If Help = Me![lstCC] ' Löschen des Empfängers aus der temporären Tabelle Set rs = CurrentDb.OpenRecordset("tblTmp_Email_Cc", dbOpenDynaset) Kriterien = "[Email] = '" & Me![lstCC] & "'" rs.FindFirst Kriterien If Not rs.NoMatch Then rs.Delete Me![lstAuswahl] = Help End If rs.Close ' Anzeige akualisieren Me![lstCC].Requery Me![lstAuswahl] = Help Exit_cmdCcDelete_Click: Exit Sub



Err_cmdCcDelete_Click: MsgBox Err.Description Resume Exit_cmdCcDelete_Click End Sub Private Sub cmdCancel_Click() On Error GoTo Err_cmdCancel_Click DoCmd.Close acForm, Me.Name Exit_cmdCancel_Click: Exit Sub Err_cmdCancel_Click: MsgBox Err.Description Resume Exit_cmdCancel_Click End Sub Private Sub cmdOK_Click() On Error GoTo Err_cmdOK_Click If Not IsNull(OpenArgs) Then Adressenübertrag End If DoCmd.Close acForm, Me.Name Exit_cmdOK_Click: Exit Sub Err_cmdOK_Click: MsgBox Err.Description Resume Exit_cmdOK_Click End Sub Private Sub Adressenübertrag() On Error GoTo Err_Adressenübertrag Dim rs As Recordset Dim Übergabe ' An Übergabe = "" If Me![lstAn].[ListCount] > 0 Then Set rs = CurrentDb.OpenRecordset("tblTmp_Email_an", dbOpenDynaset) rs.MoveFirst Übergabe = rs![Email] rs.MoveNext Do Until rs.EOF Übergabe = Übergabe & "; " & rs![Email] rs.MoveNext Loop Forms(OpenArgs)("txtAn") = Übergabe End If ' Cc Übergabe = "" If Me![lstCC].[ListCount] > 0 Then Set rs = CurrentDb.OpenRecordset("tblTmp_Email_cc", dbOpenDynaset) rs.MoveFirst Übergabe = rs![Email] rs.MoveNext Do Until rs.EOF Übergabe = Übergabe & "; " & rs![Email] rs.MoveNext Loop Forms(OpenArgs)("txtCc") = Übergabe End If



' Bcc Übergabe = "" If Me![lstBCC].[ListCount] > 0 Then Set rs = CurrentDb.OpenRecordset("tblTmp_Email_bcc", dbOpenDynaset) rs.MoveFirst Übergabe = rs![Email] rs.MoveNext Do Until rs.EOF Übergabe = Übergabe & "; " & rs![Email] rs.MoveNext Loop Forms(OpenArgs)("txtBcc") = Übergabe End If Exit_Adressenübertrag: Exit Sub Err_Adressenübertrag: MsgBox Err.Description Resume Exit_Adressenübertrag End Sub Private Sub Form_Close() On Error GoTo Err_Form_Close DoCmd.SetWarnings False DoCmd.RunSQL "DELETE Email FROM tblTmp_Email_an;" DoCmd.RunSQL "DELETE Email FROM tblTmp_Email_cc;" DoCmd.RunSQL "DELETE Email FROM tblTmp_Email_bcc;" Exit_Form_Close: DoCmd.SetWarnings True Exit Sub Err_Form_Close: MsgBox Err.Description Resume Exit_Form_Close End Sub Private Sub Form_Load() On Error GoTo Err_Form_Load Dim Empfänger As String Dim rs As Recordset ' Wenn dieses Formular aus dem Formular "frmEmail3" aufgerufen wird, ' werden die dort bereits eingetragenen Adressen in dieses Formular ' in die jeweiligen Listenfelder übernommen If Not IsNull(OpenArgs) Then If IstGeladen(OpenArgs) Then ' AN If IsNull(Forms(OpenArgs)("txtAn")) Then Empfänger = "" Else Empfänger = Forms(OpenArgs)("txtAn") End If Do Until ((Len(Empfänger) <= 0) Or (IsNull(Empfänger))) Set rs = CurrentDb.OpenRecordset("tblTmp_Email_an", _ dbOpenDynaset, dbAppendOnly) With rs .AddNew ![Email] = Empfänger_ermitteln(Empfänger) .Update End With rs.Close Loop



' CC If IsNull(Forms(OpenArgs)("txtCc")) Then Empfänger = "" Else Empfänger = Forms(OpenArgs)("txtCc") End If Do Until ((Len(Empfänger) <= 0) Or (IsNull(Empfänger))) Set rs = CurrentDb.OpenRecordset("tblTmp_Email_cc", _ dbOpenDynaset, dbAppendOnly) With rs .AddNew ![Email] = Empfänger_ermitteln(Empfänger) .Update End With rs.Close Loop ' BCC If IsNull(Forms(OpenArgs)("txtBcc")) Then Empfänger = "" Else Empfänger = Forms(OpenArgs)("txtBcc") End If Do Until ((Len(Empfänger) <= 0) Or (IsNull(Empfänger))) Set rs = CurrentDb.OpenRecordset("tblTmp_Email_bcc", _ dbOpenDynaset, dbAppendOnly) With rs .AddNew ![Email] = Empfänger_ermitteln(Empfänger) .Update End With rs.Close Loop Me![lstAn].Requery Me![lstCC].Requery Me![lstBCC].Requery End If End If Exit_Form_Load: Exit Sub Err_Form_Load: MsgBox Err.Description Resume Exit_Form_Load End Sub Function IstGeladen(MeinFormularname) On Error GoTo Err_IstGeladen Dim i IstGeladen = False For i = 0 To Forms.Count - 1 If Forms(i).FormName = MeinFormularname Then IstGeladen = True Exit Function End If Next Exit_IstGeladen: Exit Function Err_IstGeladen: MsgBox Err.Description Resume Exit_IstGeladen End Function



Function Empfänger_ermitteln(ByRef Empfänger As String) On Error GoTo Err_Empfänger_ermitteln Dim i As Byte Empfänger_ermitteln = "" If Len(Empfänger) > 0 Then If InStr(1, Empfänger, ";") > 0 Then i = InStr(1, Empfänger, ";") Empfänger_ermitteln = Trim(Left$(Empfänger, i - 1)) Empfänger = Trim(Mid$(Empfänger, i + 1)) Else Empfänger_ermitteln = Empfänger Empfänger = "" End If End If Exit_Empfänger_ermitteln: Exit Function Err_Empfänger_ermitteln: DoCmd.Hourglass False MsgBox Err.Description Resume Exit_Empfänger_ermitteln End Function

Damit dieses Formular seine Daten an das aufrufende Mailformular übergeben kann, werden die einzelnen Empfängeradressen in temporären Tabellen zwischengespeichert.

Der Aufruf des Auswahlformulars erfolgt durch das Mailformular, in dem kleine Änderungen durchgeführt wurden. An Stelle der Bezeichnungsfelder „An“, „Cc“ und „Bcc“ wurden Schaltflächen eingefügt, die das obige Formular aufrufen.



Private Sub cmdAn_Click() On Error GoTo Err_cmdAn_Click Dim stDocName As String stDocName = "frmEmail3-Auswahl" DoCmd.OpenForm stDocName, , , , , , Me.Name Exit_cmdAn_Click: Exit Sub Err_cmdAn_Click: MsgBox Err.Description Resume Exit_cmdAn_Click End Sub Private Sub cmdCc_Click() cmdAn_Click End Sub Private Sub cmdBcc_Click() cmdAn_Click End Sub

2. Druck-Manager Voreinstellungen und Voraussetzungen

Für diese Erweiterung ist die Version der Datenbank ACCESS von Bedeutung. Da ab Version 2002 (XP) die Auflistung „Printers“ im VBA-Code integriert wurde, werden hier beide Lösungen (bis Access 2000 und ab Access XP) vorgestellt.

Damit der gesamte Programmcode ordnungsgemäß funktioniert, müssen folgende Verweise aktiviert sein:

Für Access 97: - Visual Basic For Applications - Microsoft Access 8.0 Object Library - Microsoft DAO 3.51 Object Library (oder höher) - DruckManager

Für Access 2000: - Visual Basic For Applications - Microsoft Access 9.0 Object Library - Microsoft DAO 3.6 Object Library (oder höher) - OLE Automation - DruckManager

Für Access XP: - Visual Basic For Applications - Microsoft Access 10.0 Object Library - Microsoft DAO 3.6 Object Library (oder höher) - OLE Automation - Microsoft Office XP Web Components

Der hier angeführte Verweis auf „DruckManager” (Version 97 und 2000) ist extra hinzuzufügen. Dazu muss über den Button „Durchsuchen“ die Datei „DruckManager.mde“ eingebunden werden.



Windows-Funktionen: GetProfileString, GetPrivateProfileString Alle Informationen über die Drucker (welcher Drucker ist der Standarddrucker und welche Drucker sind installiert) speicherte Windows früher in der Datei WIN.INI. Diese Informationen werden ab Windows 95 in der Registry abgelegt. Allerdings werden auch in der Registry immer noch die WIN.INI oder andere INI-Dateien simuliert.

Der entsprechende Registry-Key bei Windows NT (2000 oder XP) lautet dazu: HKEY_LOCAL_MACHINE\Software\Windows\Windows NT\CurrentVersion\IniFileMapping\win.ini In diesem Bereich sind Links zu den eigentlichen Registry-Keys gespeichert, wo die entsprechenden Informationen abgelegt sind.

So sind z.B. der Standarddrucker sowie alle installierten Drucker in der Registry abgelegt. Um diese Informationen in einem Programm verwenden zu können, müssen nur mehr die Daten ausgelesen werden.

Damit diese Informationen programmtechnisch ausgelesen werden können, werden die Windows-Funktionen „GetProfileString“ und „GetPrivateProfileString“ benötigt. Der Unterschied zwischen diesen beiden Funktionen besteht darin, dass mit „GetProfileString“ nur Informationen aus der WIN.INI ausgelesen werden können. Mit „GetPrivateProfileString“ hingegen können Informationen aus jeder beliebigen INI-Datei gelesen werden.



Um diese Funktionen in einem Programm einsetzen zu können, müssen sie zu Beginn deklariert werden: Declare Function GetProfileString Lib "Kernel" Alias "GetProfileStringA"

(ByVal Sname as String, ByVal Keyname as Any, ByVal Def as String, ByVal Ret as String, ByVal Size as Integer) As Integer

Declare Function GetPrivateProfileString Lib "Kernel" " Alias "GetPrivateProfileStringA" (ByVal Sname as String, ByVal Keyname as Any, ByVal Def as String, ByVal Ret as String, ByVal Size as Integer, ByVal FileName as String) As Integer

Die Parameter im Einzelnen:

Sname: Gibt die Sektion in der Win.ini an, in der gesucht wird

Keyname: Definiert den Schlüssel, dessen Wert zurückgegeben wird

Def: Definiert einen Übergabewert (meist ein Leerstring) an die Funktion. Dieser Wert wird als Ergebnis zurückgeliefert, wenn die Suche nicht erfolgreich verläuft

Return: In dieser Variablen steht das Ergebnis der Suche. Da Windows allerdings die Größe einer Variablen nicht verändern kann, muss diese Variable bereits vorher mit einen entsprechenden Größe definiert werden!

Size: Gibt die Länge der vierten Variablen (Return) an.

FileName: Gibt den Namen der INI-Datei an (nur „GetPrivateProfileString“)

Der „Alias“-Parameter hat folgende Bedeutung: Der eigentliche Funktionsname (wie er in der DLL steht) ist case-sensitive und kommt in zwei Varianten vor: ANSI und UNICODE.

Allen ANSI-Funktionen ist ein „A“ und den UNICODE-Funktionen ein „W“ angehängt. Damit im Programmcode der Funktionsname nicht case-sensitive ist und auch sehr leicht zwischen ANSI- und UNICODE-Funktionen gewechselt werden kann, wird ein neuer Funktionsname definiert, der auf die eigentliche Funktion hinweist.

VBA verwendet dabei (in der momentanen Version) ausschließlich die ANSI-Funktionen.

Funktionen in Access 97 und 2000 Funktion „DruckerAktivSetzen“

Diese Funktion wird benötigt, um den aktuellen Standarddrucker zu wechseln. Damit wird der übergebene Drucker als systemweiter Standarddrucker gesetzt. Die Syntax lautet:

Function DruckerAktivSetzen(Druckername As String) As Boolean

Beispiel: Wenn der gewünschte Standarddrucker in einem Kombinationsfeld ausgewählt wird, sieht der Code wie folgt aus:

Ret = DruckerAktivSetzen(Me![Druckerauswahl])



Da diese Funktion einen Wert zurückliefert, muss sie einer Variablen übergeben werden, die entweder vom Typ Boolean oder Variant deklariert wird. Der Aufruf der Funktion kann auch in eine If-Anweisung eingebaut werden, um zu prüfen, ob die Druckerumstellung erfolgreich war. Dafür müsste der VB-Code so aussehen:

If Not DruckerAktivSetzen(Me![Druckerauswahl]) Then MsgBox „Die Umstellung war nicht erfolgreich.“ Else MsgBox „Der Standarddrucker wurde erfolgreich umgestellt.“ End If

Diese Funktion („DruckerAktivSetzen“) befindet sich bei Access 97 und 2000 in der Datei „DruckManager.mde“. Diese Datei muss über den Menüpunkt „Extras – Verweise“ eingebunden werden. Der gesamte Code in dieser Datei stammt aus dem Resource-Kit von Windows und ist hier abgedruckt. Damit diese Datei in das aktuelle Projekt eingebunden werden kann, muss sie anschließend in eine MDE-Datei umgewandelt werden.

Option Compare Database Option Explicit Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long Private Declare Function GetLastError Lib "kernel32" () As Long Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long Private Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, pDefault As Any) As Long Private Declare Function GetPrinter Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal cbBuf As Long, pcbNeeded As Long) As Long Private Declare Function SetPrinter Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal Command As Long) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long



Private Declare Function apiGetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Const PRINTER_ALL_ACCESS = &HF000C Private Const PRINTER_ATTRIBUTE_DEFAULT = &H4 Private Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 End Type Private Type PRINTER_DEFAULTS pDatatype As Long pDevMode As Long DesiredAccess As Long End Type Private Type PRINTER_INFO_5 pPrinterName As String pPortName As String Attributes As Long DeviceNotSelectedTimeout As Long TransmissionRetryTimeout As Long End Type Private Const HWND_BROADCAST = &HFFFF Private Const WM_WININICHANGE = &H1A '************************************************************************ ' Function DruckerAktivSetzen () ' Rückgabe: True bei Erfolg, False bei Fehlschlag ' Setzt den übergebenen Druckernamen als Standarddrucker ' Dieser Eintrag gilt als Systemstandard und nicht nur innerhalb ' von Access! ' Die Funktion prüft automatisch, ob es sich beim aktuellen System ' um Win95/98 oder Windows NT handelt und ruft die richtige Funktion auf '************************************************************************ Public Function DruckerAktivSetzen(Druckername As String) As Boolean Dim osinfo As OSVERSIONINFO Dim Ret& osinfo.dwOSVersionInfoSize = Len(osinfo) Ret& = GetVersionEx(osinfo) ' Prüfen der Windows-Platform Select Case osinfo.dwPlatformId Case 1 ' Windows 95/98 If osinfo.dwMajorVersion = 4 Then If DruckerAktivSetzen95(Druckername) Then DruckerAktivSetzen = True Else DruckerAktivSetzen = False End If End If



Case 2 ' Windows NT oder XP If (osinfo.dwMajorVersion = 3 And osinfo.dwMinorVersion = 51) _ Or (osinfo.dwMajorVersion >= 4 And osinfo.dwMinorVersion = 0) _ Or (osinfo.dwMajorVersion >= 5) Then If DruckerAktivSetzenWinNT(Druckername) Then DruckerAktivSetzen = True Else DruckerAktivSetzen = False End If End If Case Else End Select End Function '************************************************************************ ' Function DruckerAktivSetzenWin95 () ' Rückgabe: True bei Erfolg, False bei Fehlschlag ' Setzt den übergebenen Druckernamen als Standarddrucker ' Dieser Eintrag gilt als Systemstandard und nicht nur innerhalb von ' Access! '************************************************************************ Private Function DruckerAktivSetzen95(Druckername As String) As Boolean Dim Ret As Long Dim Ret2 As Long Dim Handle As Long Dim PD As PRINTER_DEFAULTS Dim PI5 As PRINTER_INFO_5 DruckerAktivSetzen95 = False If ((IsNull(Druckername)) Or (Druckername = "")) Then Exit Function End If PD.pDatatype = 0& PD.DesiredAccess = PRINTER_ALL_ACCESS Ret = OpenPrinter(Druckername, Handle, PD) If Ret = False Then Exit Function End If Ret = GetPrinter(Handle, 5, ByVal 0&, 0, Ret2) ReDim T((Ret2 \ 4)) As Long Ret = GetPrinter(Handle, 5, T(0), Ret2, Ret2) If Ret = False Then Exit Function End If PI5.pPrinterName = DruckernameSeparieren(T(0)) PI5.pPortName = DruckernameSeparieren(T(1)) PI5.Attributes = T(2) PI5.DeviceNotSelectedTimeout = T(3) PI5.TransmissionRetryTimeout = T(4) PI5.Attributes = PRINTER_ATTRIBUTE_DEFAULT Ret = SetPrinter(Handle, 5, PI5, 0) If Ret = False Then DruckerAktivSetzen95 = False Exit Function End If ClosePrinter (Handle) DruckerAktivSetzen95 = True End Function



Private Function DruckernameSeparieren(Add As Long) As String Dim str_Temp As String * 512 Dim Ret As Long Ret = lstrcpy(str_Temp, Add) If (InStr(1, str_Temp, Chr(0)) = 0) Then DruckernameSeparieren = "" Else DruckernameSeparieren = Left(str_Temp, InStr(1, str_Temp, _ Chr(0)) - 1) End If End Function '************************************************************************ ' Function DruckerAktivSetzenWinNT () ' Rückgabe: True bei Erfolg, False bei Fehlschlag ' Setzt den übergebenen Druckernamen als Standarddrucker ' Dieser Eintrag gilt als Systemstandard und nicht nur innerhalb von Acc! '************************************************************************ Private Function DruckerAktivSetzenWinNT(Druckername As String) As Boolean Dim Ret As Long Dim ReturnedString As String Dim DruckerAnschluss As String Dim Treibername As String If Len(Nz(Druckername)) > 0 Then ReturnedString = Space(1024) Ret = GetProfileString("PrinterPorts", Druckername, "", _ ReturnedString, Len(ReturnedString)) DruckertreiberUndAnschlussHolen ReturnedString, Treibername, _ DruckerAnschluss If ((Druckername <> "") And (DruckerAnschluss <> "")) Then If StandardDruckerSetzen(Druckername, Treibername, _ DruckerAnschluss) Then DruckerAktivSetzenWinNT = True Else DruckerAktivSetzenWinNT = False End If End If End If End Function '************************************************************************ ' Procedure DruckertreiberUndAnschlussHolen () ' Separiert den Namen des Druckertreibers und den DruckerAnschluss '************************************************************************ Private Sub DruckertreiberUndAnschlussHolen(ReturnedString As String, Treibername As String, DruckerAnschluss As String) Dim i_Treibername As Integer Dim i_Anschlussname As Integer Treibername = "" DruckerAnschluss = "" i_Treibername = InStr(ReturnedString, ",") If i_Treibername > 0 Then Treibername = Left(ReturnedString, i_Treibername - 1) i_Anschlussname = InStr(i_Treibername + 1, ReturnedString, ",") If i_Anschlussname > 0 Then DruckerAnschluss = Mid(ReturnedString, i_Treibername + 1, _ i_Anschlussname - i_Treibername - 1) End If End If End Sub



'************************************************************************ ' Function StandardDruckerSetzen () ' ' Rückgabe: True bei Erfolg, False bei Fehlschlag ' ' Setzt den übergebenen Druckernamen als Standarddrucker ' Dieser Eintrag gilt als Systemstandard und nicht nur innerhalb ' von Access! ' Eintrag in die win.ini und Benachrichtigung aller aktiven Programme, ' dass sich der Druckertreiber geändert hat '************************************************************************ Private Function StandardDruckerSetzen(Druckername As String, Treibername As String, DruckerAnschluss As String) As Boolean Dim Temp_String As String Dim Ret As Long Temp_String = Druckername & "," & Treibername & "," & DruckerAnschluss Ret = WriteProfileString("windows", "device", Temp_String) If Ret = 0 Then StandardDruckerSetzen = False Exit Function End If Ret = SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, "windows") If Ret = 0 Then StandardDruckerSetzen = False Else StandardDruckerSetzen = True End If End Function '************************************************************************ ' Function GetSysDir () ' Ermittelt das System-Verzeichnis von Windows '************************************************************************ Private Function GetSysDir() As String Dim lpBuffer As String * 255 Dim Length As Long Length = apiGetSystemDirectory(lpBuffer, Len(lpBuffer)) GetSysDir = Left(lpBuffer, Length) End Function

Funktionen „AktivenDruckerErmitteln“ und „AktiveDruckerListe“ Mit der Funktion „AktivenDruckerErmitteln“ wird der momentan eingestellte Standarddrucker ermittelt. Der Aufruf könnte folgendes Aussehen haben und damit einem Textfeld den Standarddrucker zuweisen: Me![txtStandarddrucker] = AktivenDruckerErmitteln

Die Funktion „AktiveDruckerListe“ ermittelt alle installierten Drucker des jeweiligen Computers. Am besten ist es, diese Ergebnisliste einem Kombinations-feld mit folgendem Aufruf zuzuweisen. Zusätzlich wird der Standarddrucker als Default-Eintrag ausgewählt: Me![cboDruckerauswahl].RowSource = AktiveDruckerListe Me![cboDruckerauswahl] = Me![txtStandarddrucker]



Option Compare Database Option Explicit Private Declare Function GetPrivateProfileString Lib "kernel32" _ Alias "GetPrivateProfileStringA" _ (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _ ByVal lpDefault As String, ByVal lpReturnedString As String, _ ByVal nSize As Long, ByVal lpFileName As String) As Long Private Declare Function GetProfileString Lib "kernel32" _ Alias "GetProfileStringA" _ (ByVal lpAppName As String, ByVal lpKeyName As String, _ ByVal lpDefault As String, ByVal lpReturnedString As String, _ ByVal nSize As Long) As Long '************************************************************************ ' Function AktivenDruckerErmitteln() ' Gibt den Namen des aktiven Druckers zurück ' Aufruf: Me![Feldname] = AktivenDruckerErmitteln '************************************************************************ Function AktivenDruckerErmitteln() Dim i As Long Dim IniEintrag As String IniEintrag = IniEintragLesen("win.ini", "windows", "device") i = InStr(1, IniEintrag, ",") If i > 0 Then IniEintrag = Left(IniEintrag, i - 1) End If AktivenDruckerErmitteln = IniEintrag End Function '************************************************************************ ' Function AktiveDruckerListe() ' Gibt eine Liste aller installieren Drucker zurück ' Aufruf: Me![Listenfeldname].RowSource = AktiveDruckerListe '************************************************************************ Function AktiveDruckerListe() Dim Ret As Long Dim ReturnedString As String ReturnedString = Space(8192) Ret = GetProfileString("PrinterPorts", vbNullString, "", _ ReturnedString, Len(ReturnedString)) ReturnedString = Trim(ReturnedString) AktiveDruckerListe = DatensatzherkunftErstellen(ReturnedString) End Function '************************************************************************ ' Function IniEintragLesen (INI-Datei, INI-Berich, INI-Eintrag) ' Liest einen Eintrag aus einer INI-Datei ' Aufruf: Me![Feldname] = IniEintragLesen("win.ini", "windows", "device") '************************************************************************ Function IniEintragLesen(IniDatei As String, IniBereich As String, _ IniEintrag As String) As String Dim Temp_Wert As Integer Dim Ret_Wert As String Const Max = 255



Ret_Wert = Space$(Max) Temp_Wert = GetPrivateProfileString(IniBereich, IniEintrag, "", _ Ret_Wert, Max, IniDatei) Ret_Wert = Trim$(Left$(Ret_Wert, InStr(Ret_Wert, Chr(0)) - 1)) IniEintragLesen = Ret_Wert End Function '************************************************************************ ' Function DatensatzherkunftErstellen () ' Rückgabe: RowSource für ein Listen- od. Kombinationsfeld ' Aufruf: Me![Kombinationsfeldname].RowSource = ' DatensatzherkunftErstellen '************************************************************************ Private Function DatensatzherkunftErstellen(ReturnedString As String) _ As String Dim i As Integer Dim Temp_String As String DatensatzherkunftErstellen = "" ' Überflüssige Zeichen ganz rechts im String wegschneiden Do While (Right(ReturnedString, 1) = Chr(0) Or _ Right(ReturnedString, 1) = " " Or Right(ReturnedString, 1) = ";") ReturnedString = Left(ReturnedString, Len(ReturnedString) - 1) Loop ' Nach "Chr(0)" (= Trennzeichen) suchen und durch ";" ersetzen Do i = InStr(ReturnedString, Chr(0)) Temp_String = "" If i > 0 Then Temp_String = Left(ReturnedString, i - 1) ReturnedString = Mid(ReturnedString, i + 1) Else Temp_String = ReturnedString ReturnedString = "" End If If Len(DatensatzherkunftErstellen) > 0 Then DatensatzherkunftErstellen = DatensatzherkunftErstellen & ";" & _ Temp_String Else DatensatzherkunftErstellen = Temp_String End If Loop While i > 0 End Function

Funktionen in Access XP In Access XP wurde das „Application“-Objekt um die Eigenschaften „Printers“ und „Printer“ erweitert. Damit ist es erstmals möglich, ohne Windows-Funktionen den Standarddrucker mit der Eigenschaft „Printer“ zu setzen bzw. alle installierten Drucker mit der „Printers“-Eigenschaft aufzulisten.

Option Compare Database Option Explicit Private Declare Function GetPrivateProfileString Lib "kernel32" _ Alias "GetPrivateProfileStringA" _ (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _ ByVal lpDefault As String, ByVal lpReturnedString As String, _ ByVal nSize As Long, ByVal lpFileName As String) As Long



Private Declare Function GetProfileString Lib "kernel32" _ Alias "GetProfileStringA" _ (ByVal lpAppName As String, ByVal lpKeyName As String, _ ByVal lpDefault As String, ByVal lpReturnedString As String, _ ByVal nSize As Long) As Long '************************************************************************ ' Function AktivenDruckerErmitteln() ' Gibt den Namen des aktiven Druckers zurück ' Aufruf: Me![Feldname] = AktivenDruckerErmitteln '************************************************************************ Function AktivenDruckerErmitteln() Dim i As Long Dim IniEintrag As String IniEintrag = IniEintragLesen("win.ini", "windows", "device") i = InStr(1, IniEintrag, ",") If i > 0 Then IniEintrag = Left(IniEintrag, i - 1) End If AktivenDruckerErmitteln = IniEintrag End Function '************************************************************************ ' Function AktiveDruckerListe() ' Gibt eine Liste aller installieren Drucker zurück ' Aufruf: Me![Listenfeldname].RowSource = AktiveDruckerListe '************************************************************************ Function AktiveDruckerListe() Dim RetString As String Dim prt As Printer RetString = Space(8192) RetString = "" For Each prt In Application.Printers If RetString = "" Then RetString = prt.DeviceName Else RetString = RetString & ";" & prt.DeviceName End If Next AktiveDruckerListe = Trim(RetString) End Function '************************************************************************ ' Function IniEintragLesen (INI-Datei, INI-Berich, INI-Eintrag) ' Liest einen Eintrag aus einer INI-Datei ' Aufruf: Me![Feldname] = IniEintragLesen("win.ini", "windows", "device") '************************************************************************ Function IniEintragLesen(IniDatei As String, IniBereich As String, _ IniEintrag As String) As String Dim Temp_Wert As Integer Dim Ret_Wert As String Const Max = 255



Ret_Wert = Space$(Max) Temp_Wert = GetPrivateProfileString(IniBereich, IniEintrag, "", _ Ret_Wert, Max, IniDatei) Ret_Wert = Trim$(Left$(Ret_Wert, InStr(Ret_Wert, Chr(0)) - 1)) IniEintragLesen = Ret_Wert End Function '************************************************************************ ' Function DruckerAktivSetzen () ' Rückgabe: True bei Erfolg, False bei Fehlschlag '************************************************************************ Function DruckerAktivSetzen(Druckername As String) As Boolean On Error GoTo Err_DruckerAktivSetzen DruckerAktivSetzen = False Application.Printer = Application.Printers(Druckername) DruckerAktivSetzen = True Exit_DruckerAktivSetzen: Exit Function Err_DruckerAktivSetzen: MsgBox Err.Description Resume Exit_DruckerAktivSetzen End Function

Beispielanwendung für die Druckerauswahl Mit Hilfe dieser kleinen Anwendung werden der Standarddrucker ausgelesen, sowie sämtliche verfügbaren Drucker und Berichte in Kombinationsfeldern aufgelistet.

Die Funktion “AktiveDruckerListe” liefert Daten für ein Kombinations- oder Listenfeld. Die Eigenschaft „Herkunftstyp“ muss dazu auf „Werteliste“ eingestellt werden!



Option Compare Database Option Explicit Private Sub cmdPrint_Click() On Error GoTo Err_cmdPrint_Click If ((Me![cboDruckerauswahl] = "") Or _ (IsNull(Me![cboDruckerauswahl]))) Then MsgBox "Sie haben keinen Drucker ausgewählt.", _ vbOKOnly + vbCritical, "Fehler" Exit Sub End If If ((Me![cboBericht] = "") Or (IsNull(Me![cboBericht]))) Then MsgBox "Sie haben keinen Bericht zum Drucken ausgewählt.", _ vbOKOnly + vbCritical, "Fehler" Exit Sub End If If Me![cboDruckerauswahl] <> Me![txtStandarddrucker] Then ' Der ausgewählte Drucker wird zum Standard gesetzt If Not DruckerAktivSetzen(Me![cboDruckerauswahl]) Then MsgBox "Bei dem Versuch, den Standarddrucker zu setzen ist " _ "ein Fehler "aufgetreten.", vbOKOnly + vbCritical, "Fehler" Exit Sub End If End If ' Für den Fall, dass der Ausdruck abgebrochen wurde, ist eine eigene ' Fehlerbehandlung nötig, damit der ursprüngliche Standarddrucker ' wieder hergestellt werden kann. On Error GoTo Err_cmdPrint2_Click DoCmd.OpenReport Me![cboBericht], acViewNormal ' Die normale Fehlerbehandlung wird wieder aktiviert On Error GoTo Err_cmdPrint_Click If Me![cboDruckerauswahl] <> Me![txtStandarddrucker] Then ' Der ursprüngliche Standarddrucker wird wieder gesetzt If Not DruckerAktivSetzen(Me![txtStandarddrucker]) Then MsgBox "Bei dem Versuch, den Standarddrucker zu setzen ist " & _ "ein Fehler aufgetreten.", vbOKOnly + vbCritical, "Fehler" Exit Sub End If ' Der aktuelle Standarddrucker wird ermittelt, falls in der vorigen ' Funktion "DruckerAktivSetzen" ein Fehler aufgetreten ist. Me![txtStandarddrucker] = AktivenDruckerErmitteln End If Exit_cmdPrint_Click: Exit Sub Err_cmdPrint_Click: MsgBox Err.Description Resume Exit_cmdPrint_Click Err_cmdPrint2_Click: MsgBox "Beim Ausduck des Berichtes ist ein Fehler aufgetreten.", _ vbOKOnly + vbCritical, "Fehler" Resume Next End Sub



Private Sub Form_Load() On Error GoTo Err_Form_Load ' Der aktuelle Standarddrucker wird ermittelt Me![txtStandarddrucker] = AktivenDruckerErmitteln ' Die Liste aller verfügbaren Drucker wird dem Listenfeld übergeben Me![cboDruckerauswahl].RowSource = AktiveDruckerListe Me![cboDruckerauswahl] = Me![txtStandarddrucker] DoCmd.GoToControl "cboBericht" Exit_Form_Load: Exit Sub Err_Form_Load: MsgBox Err.Description Resume Exit_Form_Load End Sub Private Sub cmdClose_Click() On Error GoTo Err_cmdClose_Click ' Das Formular wird geschlossen DoCmd.Close acForm, Me.Name Exit_cmdClose_Click: Exit Sub Err_cmdClose_Click: MsgBox Err.Description Resume Exit_cmdClose_Click End Sub

3. Funktionen rund um das Datum Geburtstagslisten

Mit Hilfe einer sehr einfachen Abfrage ist es möglich, die Geburtstage in eine sortierte Reihenfolge zu bringen:

Erweitert man diese Abfrage um einige selbstdefinierte Funktionen, ist es auch möglich, die Geburtstage des laufenden Jahres und das Alter zu berechnen. Weiters lässt sich sehr leicht bestimmen, ob diese Person in diesem Jahr einen runden Geburtstag feiert:



Diese Abfrage liefert folgendes Ergebnis:

Die Funktionen, die in dieser Abfrage aufgerufen werden:

Option Compare Database Option Explicit Function GebDiesesJahr(GebDat, Optional Tag) As Date If Not IsDate(GebDat) Or IsNull(GebDat) Then GebDiesesJahr = 0 Else If IsMissing(Tag) Then ' Rückgabe des Geburtstages in diesem Jahr als Datum GebDiesesJahr = Format(DateSerial(Year(Now()), Month(GebDat), _ Day(GebDat)), "dd/mm/yy") Else ' Rückgabe des Geburtstages in diesem Jahr als Wochentag GebDiesesJahr = Format(DateSerial(Year(Now()), Month(GebDat), _ Day(GebDat)), "dddd") End If End If End Function Function GebRund(GebDat) Dim Alter As Byte Dim Differenz As Byte If Not IsDate(GebDat) Or IsNull(GebDat) Then GebRund = Null Else Alter = GebAlter(GebDat)



' Ab 60 ist jedes 5. Jahr ein runder Geburtstag ' darunter alle 10 Jahre If Alter >= 60 Then Differenz = Alter Mod 5 Else Differenz = Alter Mod 10 End If If Differenz = 0 Then GebRund = "Ja" Else GebRund = "" End If End If End Function Function GebAlter(GebDat) If Not IsDate(GebDat) Or IsNull(GebDat) Then GebAlter = Null Else GebAlter = Year(Now()) - Year(GebDat) End If End Function

Geburtstage in einem bestimmten Zeitraum suchen Möchte man die Geburtstage in einem bestimmten Zeitraum (z.B +/- 15 Tage vom tatsächlichen Datum entfernt) herausfinden, kann folgende Abfrage behilflich sein:

Das berechnete Feld lautet:

GebDiesesJahr: Wenn(IstDatum([Geburtsdatum]);DatSeriell(Jahr(Jetzt()); Monat([Geburtsdatum]);Tag([Geburtsdatum]));““)

Das Kriterum dazu:

Zwischen DatAdd(„t“;Datum();-15) Und DatAdd(„t“;Datum();15)

Gesetzliche und kirchliche Feiertage Für die Berechnung der Feiertage müssen die fixen (z.B. Staatsfeiertag oder Allerheiligen) und beweglichen (z.B. Ostern oder Pfingsten) berücksichtigt werden.

Fixe Feiertage Folgende fixe Feiertage sind zu berücksichtigen:

Datum Feiertag 1. Jänner Neujahr 6. Jänner Hl. Drei Könige



1. Mai Staatsfeiertag 15. August Maria Himmelfahrt 26. Oktober Nationalfeiertag 1. November Allerheiligen 8. Dezember Maria Empfängnis 24. Dezember Hl. Abend 25. Dezember Christtag 26. Dezember Stephanitag 31. Dezember Silvester

Bewegliche Feiertage Die beweglichen Feiertage hängen in erster Linie mit Ostern zusammen. Die Berechnung dieses Datum ist äußerst aufwändig.

Der Ostersonntag ist der erste Sonntag nach dem Frühlingsvollmond. Der früheste Termin ist somit der 22. März. Dies tritt dann ein, wenn der 21. März ein Vollmond ist und dieser Tag zugleich auf einen Samstag fällt.

Für die genaue Berechnung des Ostersonntages gibt es in der Literatur bzw. im Internet eine Menge an Informationen.

Folgende beweglichen Feiertage sind zu berücksichtigen:

Datum Feiertag Ostern – 46 Aschermittwoch Ostern – 2 Karfreitag Ostern Ostersonntag Ostern + 1 Ostermontag Ostern + 39 Christi Himmelfahrt Ostern + 49 Pfingstsonntag Ostern + 50 Pfingstmontag Ostern + 60 Fronleichnam 1. Adventsonntag 2. Adventsonntag 3. Adventsonntag 4. Adventsonntag

Zur Berechnung des Ostersonntages findet man auf folgenden Internetadressen sehr gute Informationen:

http://www.ortelius.de/kalender/east_de.html http://www.assa.org.au/edm.html#Computer http://www.th-o.de/kalender.htm

Das folgende Programm zur Berechnung des Osterdatums stammt von der Webseite http://www.assa.org.au/edm.html#Computer



Function Ostern(Jahr As Integer) As Date ' EASTER DATE CALCULATION FOR YEARS 1583 TO 4099 ' jahr is a 4 digit year 1583 to 4099 ' d returns the day of the month of Easter ' m returns the month of Easter ' Easter Sunday is the Sunday following the Paschal Full Moon ' (PFM) date for the year ' This algorithm is an arithmetic interpretation of the 3 step ' Easter Dating Method developed by Ron Mallen 1985, as a vast ' improvement on the method described in the Common Prayer Book ' Because this algorithm is a direct translation of the ' official tables, it can be easily proved to be 100% correct ' This algorithm derives values by sequential inter-dependent ' calculations, so ... DO NOT MODIFY THE ORDER OF CALCULATIONS! ' The \ operator may be unfamiliar - it means integer division ' for example, 30 \ 7 = 4 (the remainder is ignored) ' All variables are integer data types ' ========================================================== Dim FirstDig As Integer 'intermediate result Dim Remain19 As Integer 'intermediate result Dim temp As Integer 'intermediate result Dim tA As Integer 'table A to E result Dim tB As Integer 'table A to E result Dim tC As Integer 'table A to E result Dim tD As Integer 'table A to E result Dim tE As Integer 'table A to E result Dim d As Integer Dim m As Integer FirstDig = Jahr \ 100 'first 2 digits of year Remain19 = Jahr Mod 19 'remainder of year / 19 ' calculate PFM date temp = (FirstDig - 15) \ 2 + 202 - 11 * Remain19 Select Case FirstDig Case 21, 24, 25, 27 To 32, 34, 35, 38 temp = temp - 1 Case 33, 36, 37, 39, 40 temp = temp - 2 End Select temp = temp Mod 30 tA = temp + 21 If temp = 29 Then tA = tA - 1 End If If (temp = 28 And Remain19 > 10) Then tA = tA - 1 End If 'find the next Sunday tB = (tA - 19) Mod 7 tC = (40 - FirstDig) Mod 4 If tC = 3 Then tC = tC + 1 End If If tC > 1 Then tC = tC + 1 End If



temp = Jahr Mod 100 tD = (temp + temp \ 4) Mod 7 tE = ((20 - tB - tC - tD) Mod 7) + 1 d = tA + tE 'return the date If d > 31 Then d = d - 31 m = 4 Else m = 3 End If Ostern = DateSerial(Jahr, m, d) End Function

Der Programmcode für das weiter unten abgebildete Formular stellt alle Feiertage eines Jahres in einer Liste zusammen:

Option Compare Database Option Explicit Function AlleFeiertage(Jahr As Integer) As String Dim Anfang As Date Dim Ende As Date Dim Tag As Date Dim FTag As String Dim Feiertage As String Anfang = DateSerial(Jahr, 1, 1) Ende = DateSerial(Jahr, 12, 31) Feiertage = "" For Tag = Anfang To Ende FTag = Feiertag(Tag) If FTag <> "" Then Feiertage = Feiertage & Format(Tag, "dd.mmm") & " - " & FTag & _ vbCrLf End If Next AlleFeiertage = Feiertage End Function Function Feiertag(datum As Date) As String Dim FTag As String Dim Jahr As Integer Dim DiffZuAdventSo As Byte Dim OsterSo As Date Dim Weihnacht As Date Jahr = Year(datum) FTag = "" OsterSo = Ostern(Jahr) Weihnacht = DateSerial(Jahr, 12, 24) ' Differenz zum letzten Adventsonntag berechnen ' Mit "vbMonday" wird der Wochenbeginn auf den Monag gesetzt If Weekday(Weihnacht, vbMonday) = 7 Then DiffZuAdventSo = 0 Else DiffZuAdventSo = Weekday(Weihnacht, vbMonday) End If



Select Case datum Case DateSerial(Jahr, 1, 1): FTag = "Neujahr" Case DateSerial(Jahr, 1, 6): FTag = "Hl. Drei Könige" Case OsterSo - 46: FTag = "Aschermittwoch" Case OsterSo - 2: FTag = "Karfreitag" Case OsterSo: FTag = "Ostersonntag" Case OsterSo + 1: FTag = "Ostermontag" Case OsterSo + 39: FTag = "Christi Himmelfahrt" Case OsterSo + 49: FTag = "Pfingstsonntag" Case OsterSo + 50: FTag = "Pfingstmontag" Case OsterSo + 60: FTag = "Fronleichnam" Case DateSerial(Jahr, 5, 1): FTag = "Staatsfeiertag" Case DateSerial(Jahr, 8, 15): FTag = "Maria Himmelfahrt" Case DateSerial(Jahr, 10, 26): Case DateSerial(Jahr, 12, 8): FTag = "Maria Empfängnis" Case Weihnacht - DiffZuAdventSo - 21: FTag = "1. Adventsonntag" Case Weihnacht - DiffZuAdventSo - 14: FTag = "2. Adventsonntag" Case Weihnacht - DiffZuAdventSo - 7: FTag = "3. Adventsonntag" Case Weihnacht - DiffZuAdventSo: FTag = "4. Adventsonntag" Case Weihnacht: FTag = "Hl. Abend" Case Weihnacht + 1: FTag = "Christtag" Case Weihnacht + 2: FTag = "Stephanitag" Case DateSerial(Jahr, 12, 31): FTag = "Silvester" End Select Feiertag = FTag End Function



Monatskalender mit Feiertagen Das folgende Formular berechnet den Kalender für ein Monat und stellt alle Feiertage darin dar:

Hinter diesem Formular verbirgt sich der folgende Progammcode:

Option Compare Database Option Explicit Const SoHintergrund = 6697881 Const SaHintergrund = 6723891 Const NormHintergrund = 16777215 Private Sub Form_Open(Cancel As Integer) Kalenderberechnung Me!Jahr, Me!Monat End Sub Private Sub Jahr_AfterUpdate() Kalenderberechnung Me!Jahr, Me!Monat End Sub Sub Kalenderberechnung(Jahr As Integer, Monat As Byte) Dim Tag As Byte Dim LetzterTag As Byte Dim i As Byte Dim j As Byte Dim x As String Dim datum As Date Dim Wochentag As Byte Dim Feiertage As String Dim FTag As String Wochentag = Weekday(DateSerial(Jahr, Monat, 1), vbMonday) LetzterTag = Format(DateSerial(Jahr, Monat + 1, 1) - 1, "d") ' Löschen der Inhalte For i = 1 To 42 x = "t" & i Me(x).Caption = "" Me(x).BackColor = NormHintergrund Next



' Monatskalender schreiben For i = 1 To LetzterTag datum = DateSerial(Jahr, Monat, i) j = i + Wochentag - 1 x = "t" & j Me(x).Caption = i If Weekday(datum, vbMonday) = 7 Then Me(x).BackColor = SoHintergrund End If If Weekday(datum, vbMonday) = 6 Then Me(x).BackColor = SaHintergrund End If FTag = Feiertag(datum) If FTag <> "" Then Me(x).BackColor = SoHintergrund Feiertage = Feiertage & Format(datum, "dd.mmm") & " - " & _ FTag & vbCrLf End If Next txtFeiertage = Feiertage End Sub Private Sub Monat_AfterUpdate() Kalenderberechnung Me!Jahr, Me!Monat End Sub

Jahreskalender Dieses Tool besteht aus mehreren Access-Objekten. Das Formular „frmJahreskalenderErstellen“ dient dazu, dass der Anwender das entsprechende Jahr eingeben kann. Es wird daraufhin die Tabelle „tblJahreskalender“ mit den entsprechenden Informationen gefüllt. Die Abfrage „qryJahreskalender“ filtert etwaige Leerzeilen heraus und korrigiert (falls nötig) die Wochenzahlen. Diese Abfrage dient als Datenquelle für den Bericht „rptJahreskalender“. Der Bericht ist dreispaltig im Querformat konfiguriert, sodass alle Monate darauf Platz haben.

Das Formular

Feiertage werden im folgenden Programmcode als negative Zahl gespeichert. Da im Bericht negative Zahlen anders formatiert werden können, ist es durch diesen Trick möglich, Feiertage sehr einfach hervorzuheben.

Option Compare Database Option Explicit Private Sub cmdCreate_Click() Kalendererstellen (Me.txtKalenderjahr) DoCmd.OpenReport "rptJahreskalender", acViewPreview End Sub



Sub Kalendererstellen(Jahr As Integer) On Error Resume Next Dim db As Database Dim rs As Recordset Dim x As String Dim y As String Dim data As Date Set db = CurrentDb() Set rs = db.OpenRecordset("tblJahreskalender", dbOpenTable) rs.MoveFirst While Not rs.EOF rs.Delete rs.MoveNext Wend For data = DateValue("1.1." & Jahr) To DateValue("31.12." & Jahr) If Format(data, "dd") = 1 Then rs.Update rs.AddNew End If x = Format$(data, "ddd") rs("Jahr") = Format(data, "yyyy") rs("Monat") = Format(data, "mm") rs("Woche") = Format(data, "ww", vbMonday, vbFirstFourDays) If Feiertag(data) = "" Then y = Format(data, "dd") Else y = -(Format(data, "dd")) End If rs(x) = y If x = "So" Then rs.Update rs.AddNew End If Next data rs.Update rs.Close Set rs = Nothing Set db = Nothing End Sub

Die Abfrage In der Abfrage werden eventuelle Leerzeilen durch das Kriterium „>0“ in der Spalte „Jahr“ ignoriert. Zusätzlich wird ein temporäres Feld „Woche1“ berechnet:

Woche1: Wenn(([woche]=53 Oder [woche]=52) Und [monat]=1;0;Wenn([woche]=1 Und [monat]=12;53;[woche]))

Diese Abfrage garantiert, dass Wochennummern am Beginn oder Ende des Jahres korrigiert werden.



Der Bericht

Dieser Bericht ist dreispaltig aufgebaut und nach „Jahr“ und „Monat“ gruppiert.



4. Euro-Rechner Dieses Modul bietet eine schnelle Umrechnung der „alten“ Währungen in Euro und umgekehrt. Der Vorteil dabei ist, dass diese Objekte ohne großen Aufwand direkt in andere Datenbanken eingefügt werden können.

Das Kernstück dieses Formulars ist ein Listenfeld („lstKurse“), das die Daten aus einer Tabelle oder Abfrage enthält:

Der Programmcode hinter diesem Formular berechnet das Ergebnis:

Option Compare Database Option Explicit Dim a As Boolean Private Sub txtEingabe_KeyUp(KeyCode As Integer, Shift As Integer) a = NeuRechnen() End Sub



Private Sub lstKurse_Click() ' Anzeigen umstellen Select Case optRechenart Case 1 lblVon.Caption = lstKurse.Column(2) lblNach.Caption = "Euro" lblArt1.Caption = "von " & lstKurse.Column(2) & " nach Euro" lblArt2.Caption = "von Euro nach " & lstKurse.Column(2) Case 2 lblVon.Caption = "Euro" lblNach.Caption = lstKurse.Column(2) lblArt1.Caption = "von " & lstKurse.Column(2) & " nach Euro" lblArt2.Caption = "von Euro nach " & lstKurse.Column(2) End Select txtEingabe.SetFocus ' Neu berechnen a = NeuRechnen() End Sub Private Sub optRechenart_Click() lstKurse_Click End Sub Private Sub cmdClose_Click() ' Formular schließen DoCmd.Close acForm, Me.Name End Sub Public Function NeuRechnen() On Error GoTo fehler If (IsNull(txtEingabe) Or txtEingabe = "") And txtEingabe.text = "" _ Then txtErgebnis = Null Else Select Case optRechenart Case 1 txtErgebnis = txtEingabe.text / lstKurse.Column(1) Case 2 txtErgebnis = txtEingabe.text * lstKurse.Column(1) End Select End If ende: Exit Function fehler: Select Case Err Case 13 MsgBox "Bitte geben Sie nur Zahlen ein!", 48, "Fehler" txtEingabe = "" txtEingabe.SetFocus Case Else MsgBox Err.Description End Select Resume ende End Function



5. Benutzerdefinierte Fortschrittsleiste Manchmal müssen in einem Datenbankprojekt komplexe, zeitraubende Aktionen durchgeführt werden, die den Anwender am Weiterarbeiten hindern. Es muss gewartet werden, bis die Aktion komplett durchgeführt wurde.

Der Programmierer kann einige programmtechnische Funktionen setzen, welche die Aktivität des Rechners signalisieren:

• Nutzung der „Hourglass“-Methode des DoCmd-Objektes, um dem Anwender zu visualisieren, dass gerade eine Berechnung oder Aktion ausgeführt wird.

• Nutzung der „Beep“-Methode des DoCmd-Objektes, um den Anwender nach Abschluss der Aktion akustisch zu informieren.

• Dialogmeldungen zu Beginn und/oder Ende einer langwierigen Aktion, damit dem Anwender mitgeteilt wird, dass längere Wartezeiten bevorstehen bzw. die Wartezeit endlich vorbei ist.

• Nutzung der Möglichkeit, mit der „SysCmd“-Funktion in der Statuszeile von Access eine kleine, aber feine Fortschrittsleiste sichtbar zu machen.

Leider ist diese SysCmd-Funktion nur sehr spartanisch ausgestattet. Der Meldungs-text kann (je nach Bildschirmauflösung) nur sehr kurz gehalten werden. Außerdem ist die Fortschrittsleiste nur sehr kurz, und die Anzeigegenauigkeit beträgt bloß 5%.

Um diese Nachteile zu umgehen, ist es sinnvoll eine eigene Fortschrittsanzeige zu programmieren, die mit wenig Aufwand in jedes Programm eingebunden werden kann.

Das Formular hat als Rahmenart die Einstellung „Dialog“ und das folgende Aussehen:

Der einzige Programmcode, der in diesem Formular steht, betrifft den „OK“-Button. Hier wird die Funktion zum Schließen des Formulars aufgerufen. Dies darf allerdings nur dann geschehen, wenn der gesamte Vorgang abgeschlossen ist. In diesem Fall hat die Variable „bolCancel“ den Inhalt „False“.



Option Compare Database Option Explicit Private Sub cmdOK_Click() Dim x As Boolean If bolCancel = False Then x = PGB_Terminate("", "", True) End If End Sub

Der Programmcode befindet sich in einem eigenen Modul. In diesem Modul werden einige Konstanten deklariert, deren Inhalt funktionsübergreifend erhalten bleiben muss.

Die Konstante „Formname“ beinhaltet den Namen des Formulars der Fortschritts-leiste. Die zweite Konstante „Schrittweite“ bestimmt das kleinste Anzeigeintervall des Fortschrittsbalkens. Damit ist es möglich, den Balken „weich“ wachsen zu lassen, da gerade bei Aktionen mit nur wenigen Zwischenschritten diese sonst sehr abrupt aussehen würden.

Folgende drei Funktionen werden verwendet:

PGB_Initialize: Öffnet das Formular zur Fortschrittsanzeige. In dieser Funktion werden außerdem die Einstellungen der verschiedenen Steuerelemente durchgeführt.

PGB_Update: Ist dafür zuständig, das Formular zur Laufzeit anzupassen, wobei die Fortschrittsleiste und auch die Meldungen bei Bedarf aktualisiert werden.

PGB_Terminate: Schließt das Formular unter bestimmten Voraussetzungen. Wird der Funktion im dritten Parameter der Wert „true“ übergeben, wird das Formular auf jeden Fall geschlossen.

Option Compare Database Option Explicit ' Variablen auf Modulebene ' ************************ ' Konstante für den Namen des Formulars Private Const Formname = "frmFortschritt" ' Bandbreite der Fortschrittsleiste Private Const Schrittweite = 15 ' Abbruch-Variable Public bolCancel As Boolean ' Maximale Schrittanzahl Private MaxSteps As Long ' Kleinste Schrittweite in Fortschrittsleiste (Progressbar) Private Increment As Long '***************************************************** '* Funktion: Fortschrittsleiste initialisieren * '* Parameter: Title = Formularüberschrift * '* Prompt = Anfangsmeldung der Aktion * '* Top = Meldungsüberschrift * '* Steps = Anzahl maximaler Schritte * '***************************************************** Public Function PGB_Initialize(ByVal Title As String, _



ByVal Prompt As String, _ Optional ByVal Top As String = "", _ Optional ByVal Steps As Long = 0) As Boolean On Error GoTo RunError Dim tof As Boolean ' Function initialisieren PGB_Initialize = False ' Abbruch-Variable auf True setzen bolCancel = True ' Formular öffnen DoCmd.OpenForm Formname:=Formname, _ View:=acNormal, _ WindowMode:=acHidden ' Überschrift im Formular einstellen Forms(Formname).Caption = Title ' automatisch Meldungsüberschrift einstellen, ' wenn der Funktion kein Wert übergeben wurde If Top = "" Then Top = "Anzahl Schritte: " & Steps End If ' Fortschrittsformular anpassen tof = PGB_Update(Prompt, Top, Steps) ' kleinste Schrittweite für Fortschritt ermitteln ' *********************************************** ' Division durch Null verhindern If Steps = 0 Then Steps = 1 End If ' Schrittweite: maximale Breite in Twips / Anzahl Schritte ' = kleinste Schrittweite in Twips Increment = Forms(Formname)![lblMaximum].Width / Steps ' maximale Anzahl Schritte zwischenspeichern MaxSteps = Steps ' Fortschrittsleiste einstellen ' (Orientierung am Maximum-Balken Forms(Formname)!lblProgressbar.Top = Forms(Formname)!lblMaximum.Top Forms(Formname)!lblProgressbar.Left = Forms(Formname)!lblMaximum.Left Forms(Formname)!lblProgressbar.Height = _ Forms(Formname)!lblMaximum.Height Forms(Formname)!lblProgressbar.Width = 0 Forms(Formname)!lblProgressbar.BackColor = RGB(0, 0, 255) ' Formular sichtbar machen Forms(Formname).Visible = True RunError: Select Case Err.Number Case 0 Case Else MsgBox Err.Description, vbCritical, "Nr. " & Err.Number End Select End Function



'***************************************************** '* Funktion: Fortschrittsleiste aktualisieren * '* Parameter: Prompt = Zwischenmeldung zur Aktion * '* Top = Meldungsüberschrift * '* Steps = aktueller Aktions-Schritt * '***************************************************** Public Function PGB_Update(Optional ByVal Prompt As String = "", _ Optional ByVal Top As String = "", _ Optional ByVal Schritt = 0) As Boolean On Error GoTo RunError Dim tof As Boolean Dim lop As Long Dim Breite As Long Dim BreiteMin As Long Dim BreiteMax As Long ' Funktion initialisieren PGB_Update = False ' Wenn Schrittlänge bzw Fortschrittsbalken verändert werden soll If Schritt <> 0 Then ' aktuelle Breite von diesem Schritt ermitteln BreiteMin = Forms(Formname)!lblProgressbar.Width ' maximale Breite nach diesem Schritt ermitteln BreiteMax = Abs(Schritt - 1) * Increment ' 'weich fließenden' Balken erzeugen, Mindesschrittgröße For Breite = BreiteMin To BreiteMax Step Schrittweite ' künstliche Wartezeit erzeugen DoEvents ' Fortschrittsleiste einstellen Forms(Formname)!lblProgressbar.Width = Breite Next End If ' Meldung über Fortscritt einstellen If Prompt <> "" Then Forms(Formname)!lblPrompt.Caption = Prompt End If ' Funktion erfolgreich PGB_Update = True RunError: Select Case Err.Number Case 0 Case Else MsgBox Err.Description, vbCritical, "Nr. " & Err.Number End Select End Function '*********************************************************** '* Funktion: Fortschrittsleiste beenden * '* Parameter: Prompt = Schlussmeldung der Aktion * '* Top = Meldungsüberschrift * '* Terminate = Erzwingt Abbruch des Formulars * '*********************************************************** Public Function PGB_Terminate(Optional ByVal Prompt As String = "", _ Optional ByVal Top As String = "", _ Optional ByVal Terminate As Boolean = False) As Boolean On Error GoTo RunError Dim tof As Boolean



' Function initialisieren PGB_Terminate = False ' Wenn Schlussbemerkung übergeben wurde, ' Formular nicht sofort schließen If Prompt <> "" Then ' Meldung über Fortschritt einstellen If Top <> "" Then Top = "Schritte vollständig" End If ' Fortschrittsleiste einstellen ' Breite der Fortschrittsleiste = maximale Breite tof = PGB_Update(Prompt, Top, MaxSteps + 1) ' Farbe der Fortschrittsleiste für erfolgreiche Aktion: blau Forms(Formname)!lblProgressbar.BackColor = RGB(150, 200, 250) ' Abbruch-Variable auf False setzen --> ' Schließen ist möglich bolCancel = False End If ' Wenn auf jeden Fall terminiert werden soll oder ' die Abbruch-Variable WAHR ist ... If Terminate = True Or bolCancel = True Then ' ... dann Formular schließen DoCmd.Close acForm, Formname End If ' Funktion erfolgreich PGB_Terminate = True RunError: Select Case Err.Number Case 0 Case Else MsgBox Err.Description, vbCritical, "Nr. " & Err.Number End Select End Function

Das folgende Programmbeispiel demonstriert die Nutzung der benutzerdefinierten Fortschrittsanzeige:

Option Compare Database Option Explicit Public Function Test_PGB() On Error GoTo RunError Dim tof As Boolean Dim txt As String Dim i As Long ' Startmeldung über Aktion erstellen txt = "Daten exportieren!" ' Fortschrittsformular initialisieren tof = PGB_Initialize("Fortschritt: Daten-Export", txt, _ "3 Schritte zum Export", 5) ' künstliche Warteschleife erzeugen For i = 1 To 1000 DoEvents Next



' Step 1 ' ****** ' Zwischenmeldung über Aktion erstellen txt = "Datenkonsistenz sicherstellen ..." ' Fortschrittsformular aktualisieren (Balken und Text) tof = PGB_Update(txt, "Schritt: 1 von 3", 1) For i = 1 To 1000 DoEvents Next ' Step 2 ' ****** ' Zwischenmeldung über Aktion erstellen txt = "Datenkonsistenz sichergestellt" & vbCrLf & _ "Export-Daten in gewünschtes Format konvertieren ..." ' Fortschrittsformular aktualisieren (Balken und Text) tof = PGB_Update(txt, "Schritt: 2 von 3", 2) For i = 1 To 2000 DoEvents Next ' Fortschrittsformular aktualisieren (nur Balken) tof = PGB_Update("", "Schritt: 2 von 3", 3) For i = 1 To 1000 DoEvents Next ' Fortschrittsformular aktualisieren (nur Balken) tof = PGB_Update("", "Schritt: 2 von 3", 4) For i = 1 To 1000 DoEvents Next ' Step 3 ' ****** ' Zwischenmeldung über Aktion erstellen txt = "Export-Daten konvertiert!" & vbCrLf & _ "Export-Daten in gewünschtes Format exportieren ..." ' Fortschrittsformular aktualisieren (Balken und Text) tof = PGB_Update(txt, "Schritt: 3 von 3", 5) For i = 1 To 1000 DoEvents Next ' Erfolgsmeldung erstellen txt = "Der Daten-Export wurde erfolgreich durchgeführt!" ' Fortschrittsformular terminieren ' mit übergebenem Meldungsext wird das Formular nicht geschlossen tof = PGB_Terminate(txt, "Aktion erfolgreich!") RunError: ' Fortschrittsformular terminieren ' ohne Meldungsext wird das Formular sofort geschlossen tof = PGB_Terminate() End Function



6. Automatische Einbindung externer Tabellen Bei größeren Access-Projekten ist es immer sinnvoll, die Programmdatei sowie die Datendatei voneinander zu trennen. Die Datentabellen werden anschließend über Verknüpfungen an die Programmdatei gebunden.

Das Problem bei dieser Verknüpfung besteht allerdings dabei, dass die Pfade zu den eingebundenen Tabellen „hard coded“ (mit fixen Pfadangaben) in einer Systemtabelle stehen. Dies führt dazu, dass diese Tabellen nicht mehr gefunden werden, wenn das gesamte Programm an einen anderen Ort verschoben wird.

Mit Hilfe dieses Programms ist es allerdings sehr leicht möglich, die Dateien an einen anderen Ort zu verschieben, da beim Start automatisch geprüft wird, ob die verknüpften Tabellen vorhanden sind. Wenn nicht, wird versucht, diese Datendatei automatisch zu suchen und die Tabellen wieder einzubinden.

Das Kernstück dazu liefert die neben- und untenstehende Tabelle. In ihr werden die wichtigsten Parameter für die Verwaltung der Datendatei gespeichert.

Das Feld „Datendatei“ gibt den Namen der Access-Datei an, in der die Datentabellen gespeichert sind.

Das Feld „DatenAktuell“ wird automatisch vom Programm verwaltet und gibt immer den aktuellen Pfad zur Programmdatei an. Sollte die Datendatei am gleichen Ort gespeichert sein, wird sie somit immer gefunden.

Im Feld „DatenAlternativ“ kann ein weiterer Speicherpfad zur Datendatei definiert werden.

Über den Parameter „Arbeitsort“ kann bestimmt werden, ob die Datendatei im Pfad „DatenAktuell“ (1) oder im Pfad „DatenAlternativ“ (2) gesucht werden soll.

Beim Starten des Programms wird das Makro „AutoExec“ ausgeführt. Dieses ruft als erstes die Funktion „Speicherplatz_festlegen()“ auf, welche den Pfad des Programms überprüft. Als nächstes wird die Funktion „Startmodul()“ aufgerufen. Diese Funktion überprüft alle eingebundenen Tabellen. Wenn notwenig, werden die Tabellen automatisch neu verknüpft.

Sollte die Datendatei nicht gefunden werden, erscheint automatisch ein Formular, mit dem es möglich ist, den Pfad zur Datendatei festzulegen. Dieses Formular erhält und speichert die Daten in der eben beschriebenen Tabelle „tblLaufwerke“.



Die Fehlermeldung „Die Datenbank…“ in diesem Formular wird von der Funktion „InitialisierungsFehlermeldung()“ erzeugt. Diese Funktion implementiert dabei automatisch den richtigen Namen der Datendatei.

Hinter diesem Formular verbirgt sich der folgende Programmcode:

Option Compare Database Option Explicit Private Sub Form_Current() Rahmen_Click End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 34 Or KeyCode = 33 Then 'PgDown oder PgUp KeyCode = 0 End If End Sub Private Sub PfadAktuell_Exit(Cancel As Integer) If Right$(PfadAktuell, 1) <> "\" Then PfadAktuell = PfadAktuell & "\" End If End Sub Private Sub PfadAlternativ_Exit(Cancel As Integer) If Right$(PfadAlternativ, 1) <> "\" Then PfadAlternativ = PfadAlternativ & "\" End If End Sub Private Sub Rahmen_Click() Select Case Rahmen Case 1 PfadAktuell.Enabled = True PfadAlternativ.Enabled = False Case 2 PfadAktuell.Enabled = False PfadAlternativ.Enabled = True End Select End Sub



Private Sub cmdClose_Click() Dim x On Error GoTo Err_cmdClose_Click DoCmd.Close x = Speicherpfad_Festlegen() x = Startmodul() Exit_cmdClose_Click: Exit Sub Err_cmdClose_Click: If Err.Number = 2501 Then Resume Next Else MsgBox Str$(Err.Number) & vbCrLf & Err.Description Resume Exit_cmdClose_Click End If End Sub Private Sub cmdAbbrechen_Click() On Error GoTo Err_cmdAbbrechen_Click MsgBox "Programm kann nicht gestartet werden, da die Datenbank " & _ "nicht gefunden wurde!" DoCmd.Quit Exit_cmdAbbrechen_Click: Exit Sub Err_cmdAbbrechen_Click: MsgBox Err.Description Resume Exit_cmdAbbrechen_Click End Sub

Das „AutoExec“-Makro ruft die beiden Funktionen auf:

Damit das Programm weiß, welche Tabellen verknüpft werden sollen, müssen diese in der Konstanten „Tabellen“ im Programmcode definiert werden. Dabei genügt es, dass die Namen der Tabellen – durch Beistriche getrennt – aufgelistet werden:

Const Tabellen = "tblBank, tblLand,tblMWSt"



Option Compare Database Option Explicit ' Namen der einzubindenden Tabellen Const Tabellen = " tblBank , tblLand,tblMWSt" Dim Speicherpfad As String Global Datendatei As String Public Function Speicherpfad_Festlegen() Dim rs As Recordset Set rs = CurrentDb.OpenRecordset("tblLaufwerke", dbOpenDynaset) Select Case rs!Arbeitsort Case 1 rs.Edit rs!PfadAktuell = getPath rs.Update Speicherpfad = rs!PfadAktuell Case 2 Speicherpfad = rs!PfadAlternativ End Select Datendatei = rs!Datendatei rs.Close End Function Function InitialisierungsFehlermeldung() Dim x As String x = "Die Datenbank '" & Datendatei & "' konnte nicht automatisch " & _ "gefunden werden!" x = x & vbCrLf & vbCrLf & "Geben Sie bitte den Pfad zur Datenbank an:" InitialisierungsFehlermeldung = x End Function Function Startmodul() Dim Tabelle, Eintrag Dim x As Byte Tabelle = Split(Tabellen, ",") For Each Eintrag In Tabelle If EingebundeneDbOK(Trim(Eintrag)) = False Then x = Tab_einbinden(Trim(Eintrag)) If x = False Then Exit Function End If End If Next DoCmd.OpenForm "frmStart", A_NORMAL DoCmd.Maximize End Function Function EingebundeneDbOK(ByVal Tabname$) On Error GoTo Nicht_Gefunden Dim db As Database Dim rs As Recordset Dim x x = DLookup("ID", "Msysobjects", "([Name]='" & Tabname & "') and _ (Type = 6)")



Set db = DBEngine.Workspaces(0).Databases(0) Set rs = db.OpenRecordset(Tabname, DB_OPEN_SNAPSHOT) rs.Close db.Close EingebundeneDbOK = True Exit Function Nicht_Gefunden: EingebundeneDbOK = False Exit Function End Function Function Tab_einbinden(ByVal Tabname$) On Error GoTo Fehler_Löschen DoCmd.DeleteObject A_TABLE, Tabname On Error GoTo Fehler_Einbinden DoCmd.TransferDatabase A_ATTACH, "Microsoft Access", Speicherpfad & _ Datendatei, A_TABLE, Tabname, Tabname Tab_einbinden = True Ende_Programm: Exit Function Fehler_Löschen: Resume Next Fehler_Einbinden: DoCmd.OpenForm "frmTabelleEinbinden", acNormal DoCmd.Maximize Tab_einbinden = False Resume Ende_Programm End Function Function getPath() Dim strTemp As String Dim lngTemp As Long strTemp = Application.CurrentDb.Name strTemp = strReverse(strTemp) lngTemp = InStr(1, strTemp, "\") If lngTemp > 0 Then strTemp = Mid(strTemp, lngTemp) End If strTemp = strReverse(strTemp) getPath = strTemp End Function Function strReverse(strText) As String Dim strTemp As String Dim lngI As Long strTemp = "" For lngI = Len(strText) To 1 Step -1 strTemp = strTemp & Mid(strText, lngI, 1) Next strReverse = strTemp End Function

Die Funktion „Split“, die in diesem Programm verwendet wird, ist erst ab Access 2000 bekannt. Sie muss daher für die früheren Versionen von Access nach-programmiert werden:



Function Split(Feld, Trennzeichen As String) Dim Eintraege() Dim i As Byte i = 0 While InStr(1, Feld, Trennzeichen) > 0 ReDim Preserve Eintraege(i) Eintraege(i) = Trim(Mid(Feld, 1, InStr(1, Feld, Trennzeichen) - 1)) i = i + 1 Feld = Trim(Mid(Feld, InStr(1, Feld, Trennzeichen) + 1)) Wend If Len(Feld) > 0 Then ReDim Preserve Eintraege(i) Eintraege(i) = Feld End If Split = Eintraege End Function

7. Kunden- und Rechnungsverwaltung Datenbankaufbau

In dieser Datenbank werden die untenstehenden Tabellen verwendet. Diese Tabellen werden in einer eigenen Datenbankdatei („Rechnungsdaten.mdb“) gespeichert. Diese Datei enthält ansonsten keine weiteren Objekte.

tblReparaturtexte: ReparaturID Autowert ReparaturKurztext Text (40) Reparaturtext Memo

tblAnrede: ID AutoWert Anrede Text (20)



tblRechnungsart: RechnungsartID Autowert Rechnungsart Text (50)

tblKunden: KKdNr AutoWert KSex Zahl (Long Integer) KFamName Text (40) KName2 Text (40) KVorname Text (20) KTitel Text (15) KStrasse Text (40) KOrt Text (40) KPlz Text (6) KTel1 Text (30) KTel2 Text (30) KHandy Text (30) KFax Text (30) KEmail Text (50) KBemerkung Memo Etikettendruck Ja/Nein Besonderheiten Zahl (Byte)

tblRechnung: RechnungsID AutoWert Rechnungsjahr Zahl (Integer) lfdNr Zahl (Long Integer) Rechnungsart Zahl (Long Integer) Kundennr Zahl (Long Integer) Auftraggeber Text (50) Rechnungsdatum Datum/Uhrzeit Zahlungsziel Zahl (Byte) MwSt Zahl (Byte) Skontoabzug Ja/Nein Bruttobetrag Zahl (Double) Zahlbetrag Zahl (Double) StornoRechnungsID Zahl (Long Integer) StornierteRechnung Ja/Nein StornoID Text (7)

tblRechnungsdetails: DetailID AutoWert RechnungsID Zahl (Long Integer) Beschreibung Text (255) Preis Zahl (Double)

tblZahlbeträge: BezahltID AutoWert RechnungsID Zahl (Long Integer) Buchungsdatum Datum/Uhrzeit Zahlbetrag Zahl (Double)

Kundenverwaltung Das Formular „frmKundenEingabe“ erhält die Daten aus der Abfrage „qryAlleKunden“. In dieser Abfrage werden alle Kunden alphabetisch sortiert.

Das Formular selbst könnte folgendes Aussehen haben:



Der Großteil des VBA-Codes in diesem Formular stammt vom Assistenten. Beim Schließen des Formulars muss allerdings darauf geachtet werden, ob das Formular direkt oder vom Rechnungsformular aus aufgerufen wurde. Sollte das Formular nicht direkt aus dem Datenbankfenster oder Startformular aufgerufen worden sein, besitzt die Eigenschaft „Marke“ („Tag“) des Formulars den Namen des auf-rufenden Formulars. In diesem Fall müssen die Daten an das Rechnungsformular übermittelt und aktualisiert werden.

Aus Sicherheitsgründen ist die Bearbeitung der Datenfelder im Normalfall nicht möglich. Erst durch einen Klick auf den „Bearbeiten“-Button werden die Felder für das Bearbeiten freigegeben. In diesem Fall wird die globale Prozedur „FelderSperren“ aufgerufen. Diese Prozedur benötigt den Namen des aufrufenden Formulars und den booleschen Wert, ob die Felder gesperrt oder freigegeben werden müssen. Diese Prozedur berücksichtigt ausschließlich Text- oder Kombinationsfelder, bei denen die Eigenschaft „Marke“ keinen Eintrag besitzt.

Public Sub FelderSperren(formular As String, sperre As Boolean) Dim ctl For Each ctl In Forms(formular).Controls If TypeOf ctl Is TextBox Or TypeOf ctl Is ComboBox Then If Not ctl.Tag <> "" Then If sperre = True Then ctl.Locked = True ctl.Enabled = False ctl.BackColor = RGB(255, 255, 200) Forms(formular)!cmdEdit.Caption = "Bearbeiten" Else ctl.Locked = False ctl.Enabled = True ctl.BackColor = RGB(255, 255, 255) Forms(formular)!cmdEdit.Caption = "Speichern" End If End If End If Next End Sub



Hinter dem Kundenformular befindet sich der folgende VBA-Code:

Option Compare Database Option Explicit Private Sub cboSuchfeld_AfterUpdate() Dim rs As Recordset Set rs = Me.RecordsetClone rs.FindFirst "KKdNr = " & Me!cboSuchfeld Me.Bookmark = rs.Bookmark rs.Close Me!cboSuchfeld = "" End Sub Private Sub Form_Current() cmdClose.SetFocus If NeuerKunde = False Then FelderSperren Me.Name, True Else FelderSperren Me.Name, False KFamName.SetFocus End If End Sub Private Sub cmdFirst_Click() On Error GoTo Err_cmdFirst_Click DoCmd.GoToRecord , , acFirst Exit_cmdFirst_Click: Exit Sub Err_cmdFirst_Click: MsgBox Err.Description Resume Exit_cmdFirst_Click End Sub Private Sub cmdPrev_Click() On Error GoTo Err_cmdPrev_Click DoCmd.GoToRecord , , acPrevious Exit_cmdPrev_Click: Exit Sub Err_cmdPrev_Click: MsgBox Err.Description Resume Exit_cmdPrev_Click End Sub Private Sub cmdNext_Click() On Error GoTo Err_cmdNext_Click DoCmd.GoToRecord , , acNext Exit_cmdNext_Click: Exit Sub Err_cmdNext_Click: MsgBox Err.Description Resume Exit_cmdNext_Click End Sub



Private Sub cmdLast_Click() On Error GoTo Err_cmdLast_Click DoCmd.GoToRecord , , acLast Exit_cmdLast_Click: Exit Sub Err_cmdLast_Click: MsgBox Err.Description Resume Exit_cmdLast_Click End Sub Private Sub cmdPrint_Click() On Error GoTo Err_cmdPrint_Click DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70 DoCmd.PrintOut acSelection Exit_cmdPrint_Click: Exit Sub Err_cmdPrint_Click: MsgBox Err.Description Resume Exit_cmdPrint_Click End Sub Private Sub cmdNew_Click() On Error GoTo Err_cmdNew_Click DoCmd.GoToRecord , , acNewRec Exit_cmdNew_Click: Exit Sub Err_cmdNew_Click: MsgBox Err.Description Resume Exit_cmdNew_Click End Sub Private Sub cmdDele_Click() On Error GoTo Err_cmdDele_Click DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70 DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70 Exit_cmdDele_Click: Exit Sub Err_cmdDele_Click: MsgBox Err.Description Resume Exit_cmdDele_Click End Sub Private Sub cmdClose_Click() On Error GoTo Err_cmdClose_Click If Me.Tag = "frmRechnung" Then DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , _ acMenuVer70 Forms!frmRechnung!Kundennr.Requery If Not IsNull(Me!KKdNr) Then Forms!frmRechnung!Kundennr = Me!KKdNr Forms!frmRechnung!sfrmKunden.Requery End If End If DoCmd.Close acForm, "frmKundenEingabe" NeuerKunde = False Exit_cmdClose_Click: Exit Sub Err_cmdClose_Click: MsgBox Err.Description Resume Exit_cmdClose_Click End Sub



Private Sub cmdEdit_Click() On Error GoTo Err_cmdEdit_Click If cmdEdit.Caption = "Speichern" Then FelderSperren Me.Name, True If Me.Tag <> "frmRechnung" Then cmdNext.Enabled = True cmdPrev.Enabled = True cmdFirst.Enabled = True cmdLast.Enabled = True cmdPrint.Enabled = True cmdNew.Enabled = True cmdDele.Enabled = True End If Else If MsgBox("ACHTUNG!!! ACHTUNG!!! ACHTUNG!!! ACHTUNG!!!" & vbCrLf & _ vbCrLf & "Änderungen an diesem Datensatz können sich auch auf " & _ "andere Rechnungen auswirken!" & vbCrLf & vbCrLf & _ "Möchten Sie den Datensatz wirklich bearbeiten?", _ vbYesNo + vbCritical + vbDefaultButton2, _ "Datensatz wird geändert!") = vbYes Then FelderSperren Me.Name, False cmdNext.Enabled = False cmdPrev.Enabled = False cmdFirst.Enabled = False cmdLast.Enabled = False cmdPrint.Enabled = False cmdNew.Enabled = False cmdDele.Enabled = False End If End If DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70 Exit_cmdEdit_Click: Exit Sub Err_cmdEdit_Click: MsgBox Err.Description Resume Exit_cmdEdit_Click End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) ' Das Wechseln des Datensatzes mit PgDown oder PgUp soll ' verhindert werden If KeyCode = 34 Or KeyCode = 33 Then KeyCode = 0 End If End Sub

Reparaturtexte verwalten Dieses kleine Endlos-Formular bietet die Möglichkeit, Reparaturtexte zu verwalten, sodass diese im Rechnungsformular nicht jedes Mal neu geschrieben werden müssen.



Etikettenausdrucke von Kundenadressen Da Kunden des Öfteren mit aktuellen Informationen versorgt werden müssen, ist es empfehlenswert, die Möglichkeit, Etiketten drucken zu können, in das Programm zu implementieren.

Im folgenden Formular kann der Benutzer die Kunden nach Name oder PLZ sortieren. Das Listenfeld erhält daher seine Daten aus zwei unterschiedlichen Abfragen: qryKundenEtiketten nach Name sortiert qryKundenEtiketten nach PLZ sortiert

Die Zuweisung der Abfragen erfolgt durch die Voreinstellung (Sortierung nach Name) bzw. durch einen Klick innerhalb der Optionsgruppe „optSortierung“. Dabei wird durch Aufruf eines Ereignisses die Eigenschaft „Datenherkunft“ („RowSource“) des Listenfeldes verändert.

Die entsprechenden SQL-Strings für diese Abfragen lauten:

qryKundenEtiketten nach Name sortiert:

SELECT tblKunden.KKdNr, [Anrede] & " " & [KTitel] AS KAnrede, [KFamName] & " " & [KVorname] AS Name, tblKunden.KName2 AS Name2, tblKunden.KStrasse AS Straße, tblKunden.KPlz AS PLZ, tblKunden.KOrt AS Ort FROM tblAnrede INNER JOIN tblKunden ON tblAnrede.ID = tblKunden.KSex ORDER BY tblKunden.KFamName, tblKunden.KVorname;

qryKundenEtiketten nach PLZ sortiert:

SELECT tblKunden.KKdNr, [Anrede] & " " & [KTitel] AS KAnrede, [KFamName] & " " & [KVorname] AS Name, tblKunden.KName2 AS Name2, tblKunden.KStrasse AS Straße, tblKunden.KPlz AS PLZ, tblKunden.KOrt AS Ort FROM tblAnrede INNER JOIN tblKunden ON tblAnrede.ID = tblKunden.KSex ORDER BY tblKunden.KPlz, tblKunden.KFamName, tblKunden.KVorname;

Die Spaltenbreiten für das Listenfeld sind folgendermaßen eingestellt: 0cm;2cm;5cm;4,503cm;3,503cm;1cm;3cm

Damit die Mehrfachauswahl sowohl mit „Shift“ als auch mit „Strg“ möglich ist, muss die Eigenschaft „Mehrfachauswahl“ auf „Erweitert“ eingestellt werden.



Option Compare Database Option Explicit Private Sub cmdAlle_Click() Dim i% DoCmd.Hourglass True For i = 0 To Me!lstKunden.ListCount - 1 Me!lstKunden.Selected(i) = True Next DoCmd.Hourglass False End Sub Private Sub cmdKeine_Click() Dim i% DoCmd.Hourglass True For i = 0 To Me!lstKunden.ListCount - 1 Me!lstKunden.Selected(i) = False Next DoCmd.Hourglass False End Sub Private Sub cmdPrint_Click() On Error GoTo Err_cmdPrint_Click Dim stDocName As String Dim rs As Recordset Dim fm As Form Dim i As Long If Me!lstKunden.ItemsSelected.Count > 0 Then DoCmd.Hourglass True Set rs = CurrentDb.OpenRecordset("tblKunden", dbOpenDynaset) On Error Resume Next While Not rs.EOF rs.Edit rs![Etikettendruck] = True rs.Update rs.MoveNext Wend



DoCmd.Hourglass False rs.Close If Me!optSortierung = 1 Then stDocName = "rptKundenetiketten nach Name sortiert" Else stDocName = "rptKundenetiketten nach PLZ sortiert" End If DoCmd.OpenReport stDocName, acPreview Else MsgBox "Es wurden keine Datensätze ausgewählt!" End If Exit_cmdPrint_Click: Exit Sub Err_cmdPrint_Click: MsgBox Err.Description Resume Exit_cmdPrint_Click End Sub Private Sub cmdClose_Click() On Error GoTo Err_cmdClose_Click DoCmd.Close Exit_cmdClose_Click: Exit Sub Err_cmdClose_Click: MsgBox Err.Description Resume Exit_cmdClose_Click End Sub Private Sub cmdSelectPrint_Click() Dim stDocName As String Dim rs As Recordset Dim fm As Form Dim i As Long If Me!lstKunden.ItemsSelected.Count > 0 Then DoCmd.Hourglass True Set rs = CurrentDb.OpenRecordset("tblKunden", dbOpenDynaset) On Error Resume Next While Not rs.EOF rs.Edit rs![Etikettendruck] = False rs.Update rs.MoveNext Wend On Error GoTo 0 For i = 0 To Me!lstKunden.ListCount - 1 rs.FindFirst "[KKdNr] = " & Me!lstKunden.Column(0, i) rs.Edit If lstKunden.Selected(i) Then rs![Etikettendruck] = True End If rs.Update Next rs.Close DoCmd.Hourglass False



If Me!optSortierung = 1 Then stDocName = "rptKundenetiketten nach Name sortiert" Else stDocName = "rptKundenetiketten nach PLZ sortiert" End If DoCmd.OpenReport stDocName, acPreview Else MsgBox "Es wurden keine Datensätze ausgewählt!" End If End Sub Private Sub Form_Current() Dim rs As Recordset cmdKeine_Click optSortierung = 1 End Sub Private Sub optSortierung_Click() If optSortierung = 1 Then lstKunden.RowSource = "qryKundenEtiketten nach Name sortiert" Else lstKunden.RowSource = "qryKundenEtiketten nach PLZ sortiert" End If End Sub

Für das Ausdrucken der Etiketten sind zwei Berichte „rptKundenetiketten nach Name sortiert“ und „rptKundenetiketten nach PLZ sortiert“ erforderlich. Beide Berichte erhalten die Daten aus der Abfrage „qryKundenEtikettenSelected“, die folgende Definition besitzt:

SELECT [Anrede] & " " & [KTitel] AS KAnrede, [KFamName] & " " & [KVorname] AS KdName, tblKunden.KName2, tblKunden.KStrasse, tblKunden.KPlz, tblKunden.Kort FROM tblAnrede INNER JOIN tblKunden ON tblAnrede.ID = tblKunden.KSex WHERE (((tblKunden.Etikettendruck)=Yes)) ORDER BY tblKunden.KFamName, tblKunden.KVorname;

Die Erstellung der Berichte erfolgt am besten durch die Verwendung des Etiketten-Assistents. Die Berichte unterscheiden sich dabei ausschließlich in der Sortierung der Daten.



Rechnungsformular Um im Rechnungsformular „frmRechnung“ die Daten des ausgewählten Kunden kontrollieren zu können, werden diese Informationen in einem Unterformular aufbereitet:

Im Hauptformular, das die einzelnen Rechnungen verwaltet, sind zusätzliche Unterformulare (Endlosformulare) für die Rechnungsdetails bzw. Zahlungs-eingänge implementiert.

Die Standardwerte für die Felder „txtRechnungsjahr“ und „txtLfdNr“ werden mit Hilfe der Funktionen „Jahrberechnen()“ bzw. „RechnungsnummerBerechnen()“ ermittelt.

Da die Einzelbeträge als Bruttobeträge in das Unterformular eingegeben werden, wird der Gesamt-Bruttopreis mit folgender Formel aus den Einzelbeträgen ermittelt: =DomSumme("[Preis]";"tblRechnungsdetails";"RechnungsID=" & [RechnungsID])

Der Nettobetrag bzw. die MwSt werden aus dem Gesamt-Bruttopreis ermittelt: =[txtBrutto]/(1+[MwSt]/100) =[txtNetto]*[MwSt]/100



Da auch die einzelnen Zahlungseingänge in einer eigenen Tabelle erfasst werden, wird der insgesamt bezahlte Betrag mit einer Formel ermittelt:

=Wenn(DomSumme("[Zahlbetrag]";"[tblZahlbeträge]";"[RechnungsID] =" & [RechnungsID])>0;DomSumme("[Zahlbetrag]";"[tblZahlbeträge]"; "[RechnungsID] =" & [RechnungsID]);0)

Im linken unteren Bereich des Formulars befinden sich zwei weitere Objekte: „lblStornoID“ und „lblStornoID2“. Diese beiden Objekte sind nur dann sichtbar, wenn es sich um stornierte Rechnungen handelt.

Der Programmcode in diesem Formular sieht folgendermaßen aus:



Option Compare Database Option Explicit Function JahrBerechnen() JahrBerechnen = Right$(Year(Me!txtRechnungsdatum), 2) End Function Private Sub cboSuchfeld_AfterUpdate() Dim rs As Recordset Set rs = Me.RecordsetClone rs.FindFirst "RechnungsID = " & Me!cboSuchfeld Me.Bookmark = rs.Bookmark rs.Close Me!cboSuchfeld = "" End Sub Private Sub cmdKundeEdit_Click() On Error GoTo Err_cmdKundeEdit_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmKundenEingabe" stLinkCriteria = "[KKdnr]=" & Me![Kundennr] DoCmd.OpenForm FormName:=stDocName, WhereCondition:=stLinkCriteria Forms(stDocName)!cmdFirst.Enabled = False Forms(stDocName)!cmdPrev.Enabled = False Forms(stDocName)!cmdNext.Enabled = False Forms(stDocName)!cmdLast.Enabled = False Forms(stDocName)!cmdPrint.Enabled = False Forms(stDocName)!cmdDele.Enabled = False Forms(stDocName)!cmdNew.Enabled = False Forms(stDocName).Tag = Me.Name Exit_cmdKundeEdit_Click: Exit Sub Err_cmdKundeEdit_Click: MsgBox Err.Description Resume Exit_cmdKundeEdit_Click End Sub Private Sub cmdKundeNew_Click() On Error GoTo Err_cmdKundeNew_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmKundenEingabe" NeuerKunde = True DoCmd.OpenForm stDocName, , , stLinkCriteria, acFormAdd Forms(stDocName)!cmdFirst.Enabled = False Forms(stDocName)!cmdPrev.Enabled = False Forms(stDocName)!cmdNext.Enabled = False Forms(stDocName)!cmdLast.Enabled = False Forms(stDocName)!cmdPrint.Enabled = False Forms(stDocName)!cmdDele.Enabled = False Forms(stDocName)!cmdNew.Enabled = False Forms(stDocName).Tag = Me.Name



Exit_cmdKundeNew_Click: Exit Sub Err_cmdKundeNew_Click: MsgBox Err.Description Resume Exit_cmdKundeNew_Click End Sub Private Sub Form_Current() If IsNull(Kundennr) Or Kundennr = 0 Or Kundennr = "" Then txtNetto.Visible = False txtMwSt.Visible = False txtBrutto.Visible = False txtBezahlt.Visible = False txtOffen.Visible = False Else txtNetto.Visible = True txtMwSt.Visible = True txtBrutto.Visible = True txtBezahlt.Visible = True txtOffen.Visible = True End If If Bruttobetrag.Value > Zahlbetrag.Value Then txtOffen.ForeColor = RGB(255, 0, 0) Skontoabzug.Visible = True Else txtOffen.ForeColor = RGB(0, 0, 0) Skontoabzug.Visible = False End If If StornierteRechnung = True Then lblStornoID.Visible = True txtStornoID.Visible = True Else lblStornoID.Visible = False txtStornoID.Visible = False End If If StornoRechnungsID <> 0 Then lblStornoID2.Visible = True txtStornoID2.Visible = True Else lblStornoID2.Visible = False txtStornoID2.Visible = False End If If StornierteRechnung = True Or StornoRechnungsID <> 0 Then Me!sfrmZahlbeträge.Locked = True Me!sfrmZahlbeträge.Enabled = False Me!sfrmRechnungsdetails.Locked = True Me!sfrmRechnungsdetails.Enabled = False Skontoabzug.Enabled = False MwSt.Enabled = False Else Me!sfrmZahlbeträge.Locked = False Me!sfrmZahlbeträge.Enabled = True Me!sfrmRechnungsdetails.Locked = False Me!sfrmRechnungsdetails.Enabled = True Skontoabzug.Enabled = True MwSt.Enabled = True End If End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 34 Or KeyCode = 33 Then 'PgDown oder PgUp KeyCode = 0 End If End Sub



Private Sub Kundennr_AfterUpdate() txtNetto.Visible = True txtMwSt.Visible = True txtBrutto.Visible = True txtBezahlt.Visible = True txtOffen.Visible = True End Sub Private Sub txtRechnungsdatum_Exit(Cancel As Integer) If Me!Rechnungsdatum <> Date Then If MsgBox("Wollen Sie das Datum wirklich ändern?", vbYesNo + _ vbQuestion + vbDefaultButton2, "Datumsänderung!") = vbNo Then txtRechnungsdatum.Value = Format(Now, "DD.MM.YYYY") End If End If End Sub Private Sub cmdFirst_Click() On Error GoTo Err_cmdFirst_Click DoCmd.GoToRecord , , acFirst Exit_cmdFirst_Click: Exit Sub Err_cmdFirst_Click: MsgBox Err.Description Resume Exit_cmdFirst_Click End Sub Private Sub cmdPrevious_Click() On Error GoTo Err_cmdPrevious_Click DoCmd.GoToRecord , , acPrevious Exit_cmdPrevious_Click: Exit Sub Err_cmdPrevious_Click: MsgBox Err.Description Resume Exit_cmdPrevious_Click End Sub Private Sub cmdNext_Click() On Error GoTo Err_cmdNext_Click Rechnungsart.SetFocus DoCmd.GoToRecord , , acNext Exit_cmdNext_Click: Exit Sub Err_cmdNext_Click: MsgBox Err.Description Resume Exit_cmdNext_Click End Sub Private Sub cmdLast_Click() On Error GoTo Err_cmdLast_Click Rechnungsart.SetFocus DoCmd.GoToRecord , , acLast Exit_cmdLast_Click: Exit Sub



Err_cmdLast_Click: MsgBox Err.Description Resume Exit_cmdLast_Click End Sub Private Sub cmdNew_Click() On Error GoTo Err_cmdNew_Click Rechnungsart.SetFocus DoCmd.GoToRecord , , acNewRec Exit_cmdNew_Click: Exit Sub Err_cmdNew_Click: MsgBox Err.Description Resume Exit_cmdNew_Click End Sub Private Sub cmdClose_Click() On Error GoTo Err_cmdClose_Click txtBezahlt.Requery Zahlbetrag = txtBezahlt If Me.Tag <> "" Then DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , _ acMenuVer70 On Error Resume Next Forms![frmMahnungen]!lstMahnungen.Requery Forms![frmKundensuche]!lstKunden.Requery On Error GoTo Err_cmdClose_Click End If DoCmd.Close Exit_cmdClose_Click: Exit Sub Err_cmdClose_Click: MsgBox Err.Description Resume Exit_cmdClose_Click End Sub Private Sub cmdPrint_Click() On Error GoTo Err_cmdPrint_Click Dim stDocName As String Dim stLinkCriteria As String Dim i As Byte stDocName = "rptRechnung" stLinkCriteria = "[RechnungsID]=" & Me![RechnungsID] DoCmd.OpenReport stDocName, acNormal, , stLinkCriteria Exit_cmdPrint_Click: Exit Sub Err_cmdPrint_Click: MsgBox Err.Description Resume Exit_cmdPrint_Click End Sub



Rechnungen stornieren

Wird eine Rechnung storniert, darf diese bestehende Rechnung nicht einfach gelöscht werden. Weil die Gesamtumsätze im Betrieb aber trotzdem stimmen müssen, wird das Stornieren einer Rechnung in diesem Beispiel so gelöst, dass eine weitere Rechnung erstellt wird, welche die vorher definierten Rechnungsbeträge negativ darstellt. Somit ist der Gesamtumsatz ausgeglichen. Diese beiden Rechnungen werden allerdings im Formular entsprechend gekennzeichnet, wie in untenstehenden Abbildungen zu sehen ist.



Der Programmcode hinter dem Storno-Formular:

Option Compare Database Option Explicit Private Sub cmdClose_Click() On Error GoTo Err_cmdClose_Click DoCmd.Close Exit_cmdClose_Click: Exit Sub Err_cmdClose_Click: MsgBox Err.Description Resume Exit_cmdClose_Click End Sub Private Sub cboSuchfeld_AfterUpdate() Dim rs As Recordset Dim kriterium As String Dim Rechnungsjahr As Integer Dim lfdNr As Long Dim Kundennr As Long Dim Auftraggeber As String Dim MwSt As Byte Dim Bruttobetrag As Double Dim Zahlbetrag As Double Dim RechnungsID As Long Dim Beschreibung() As String Dim Preis() As Double Dim Detailanz As Byte Dim StornoRechnungsID As Long Dim StornoNrAlt As String Dim StornoNrNeu As String Dim i As Byte Dim stDocName As String Dim stLinkCriteria As String If MsgBox("Soll die ausgewählte Rechnung wirklich storniert werden?",_ vbQuestion + vbYesNo + vbDefaultButton2, "Warnung!") = vbYes Then Set rs = CurrentDb.OpenRecordset("tblRechnung", dbOpenDynaset) kriterium = "RechnungsID = " & Me!cboSuchfeld rs.FindFirst kriterium Rechnungsjahr = rs!Rechnungsjahr lfdNr = rs!lfdNr StornoNrAlt = Format(Rechnungsjahr, "00") & Format(lfdNr, "00000") Kundennr = rs!Kundennr If Not IsNull(rs!Auftraggeber) Then Auftraggeber = rs!Auftraggeber MwSt = rs!MwSt Bruttobetrag = rs!Bruttobetrag Zahlbetrag = rs!Zahlbetrag StornoRechnungsID = rs!RechnungsID rs.Edit rs!StornierteRechnung = True rs.Update rs.AddNew rs!Rechnungsjahr = Right$(Year(Date), 2) rs!lfdNr = RechnungsnummerBerechnen() Rechnungsjahr = rs!Rechnungsjahr lfdNr = rs!lfdNr StornoNrNeu = Format(Rechnungsjahr, "00") & Format(lfdNr, "00000") rs!Rechnungsart = 3 rs!Kundennr = Kundennr If Auftraggeber <> "" Then rs!Auftraggeber = Auftraggeber



rs!Rechnungsdatum = Date rs!Zahlungsziel = 0 rs!MwSt = MwSt rs!Skontoabzug = False rs!Bruttobetrag = -Bruttobetrag rs!Zahlbetrag = Zahlbetrag rs!StornoRechnungsID = StornoRechnungsID rs!StornoID = StornoNrAlt rs.Update rs.MoveLast RechnungsID = rs!RechnungsID kriterium = "RechnungsID = " & Me!cboSuchfeld rs.FindFirst kriterium rs.Edit rs!StornoID = StornoNrNeu rs.Update rs.Close Set rs = CurrentDb.OpenRecordset("tblRechnungsdetails", _ dbOpenDynaset) kriterium = "RechnungsID = " & Me!cboSuchfeld rs.FindFirst kriterium While Not rs.NoMatch Detailanz = Detailanz + 1 rs.FindNext kriterium Wend ReDim Beschreibung(Detailanz) ReDim Preis(Detailanz) rs.FindFirst kriterium i = 1 While Not rs.NoMatch If Not IsNull(rs!Beschreibung) And rs!Beschreibung <> "" Then Beschreibung(i) = rs!Beschreibung End If Preis(i) = rs!Preis i = i + 1 rs.FindNext kriterium Wend For i = 1 To Detailanz rs.AddNew rs!RechnungsID = RechnungsID If Not IsNull(Beschreibung(i)) And Beschreibung(i) <> "" Then rs!Beschreibung = Beschreibung(i) End If rs!Preis = -Preis(i) rs.Update Next MsgBox "Die Rechnung wurde storniert!" rs.Close stDocName = "rptRechnung" stLinkCriteria = "[StornoRechnungsID]=" & Me!cboSuchfeld DoCmd.OpenReport stDocName, acNormal, , stLinkCriteria DoCmd.Close End If End Sub



Kunden samt Rechnungen suchen Im folgenden Formular können Kunden gesucht werden. Im Listenfeld werden alle Rechnungen dieses Kunden aufgelistet. Durch einen Doppelklick auf eine entsprechende Zeile wird daraufhin sofort diese Rechnung angezeigt und kann bearbeitet werden.

Das Listenfeld erhält die Daten aus der Abfrage „qryKundensuche“:



Der gesamte SQL-String zu dieser Abfrage lautet:

SELECT tblKunden.KKdNr, tblRechnung.RechnungsID, [KFamname] & " " & [KVorname] & IIf(Not IsNull([KName2]) And [KName2]<>"",", " & [Kname2],"") AS Kunde, Format([Rechnungsjahr],"00") & Format([lfdNr],"00000") AS [Re-Nr], Format([Rechnungsdatum], "dd/mm/yy") AS [Re-Datum], Format([rechnungsdatum]+[Zahlungsziel], "dd/mm/yy") AS Fällig, tblREchnungsart.Rechnungsart AS Art, ZahlRechtsbündig(Format([Bruttobetrag],"000,000.00")) AS Brutto, ZahlRechtsbündig(Format([Zahlbetrag],"000,000.00")) AS Bezahlt, Zahlrechtsbündig(Format(IIf([skontoabzug]=True,0,IIf([Zahlbetrag]>0 ,[Bruttobetrag]-[Zahlbetrag],[Bruttobetrag])),"000,000.00")) AS Offen, tblRechnung.Skontoabzug AS Skonto FROM tblREchnungsart INNER JOIN (tblKunden INNER JOIN tblRechnung ON tblKunden.KKdNr = tblRechnung.Kundennr) ON tblREchnungsart.RechnungsartID = tblRechnung.Rechnungsart WHERE (((tblKunden.KKdNr)=[Formulare]![frmKundensuche]![cboSuchfeld]));

In dieser Abfrage wird die allgemeine Funktion „ZahlRechtsbündig“ aufgerufen. Diese Funktion hat folgendes Aussehen:

Public Function ZahlRechtsbündig(x As String) As String Dim i As Byte Dim z As String Dim negativ As Boolean z = x i = 1 negativ = False If Left(z, i) = "-" Then z = Mid(z, i + 1, Len(z) - 1) negativ = True End If While Mid(z, i, 1) = "0" Or Mid(z, i, 1) = "." Or Mid(z, i, 1) = "," Mid(z, i, 1) = " " i = i + 1 Wend If negativ Then Mid(z, i - 1, 1) = "-" End If ZahlRechtsbündig = z End Function

Der Programmcode in diesem Formular öffnet das Rechnungsformular, wenn auf eine Rechnungszeile ein Doppelklick durchgeführt wird:

Option Compare Database Option Explicit Private Sub cboSuchfeld_AfterUpdate() lstKunden.Requery End Sub Private Sub cmdClose_Click() On Error GoTo Err_cmdClose_Click DoCmd.Close Exit_cmdClose_Click: Exit Sub



Err_cmdClose_Click: MsgBox Err.Description Resume Exit_cmdClose_Click End Sub Private Sub lstKunden_DblClick(Cancel As Integer) DoCmd.OpenForm "frmRechnung", acNormal, , "Rechnungsid = " & _ lstKunden.Column(1, lstKunden.ItemsSelected(0)) Forms![frmRechnung].Tag = Me.Name Forms![frmRechnung]!cmdFirst.Enabled = False Forms![frmRechnung]!cmdPrevious.Enabled = False Forms![frmRechnung]!cmdNext.Enabled = False Forms![frmRechnung]!cmdLast.Enabled = False Forms![frmRechnung]!cmdNew.Enabled = False End Sub

Zahlungseingänge erfassen Um Zahlungseingänge schneller erfassen zu können, wurde dieses Formular entwickelt.

Mit Hilfe des Kombinationsfeldes kann die entsprechende Rechnungsnummer gesucht werden. Die darüberliegende Optionsgruppe bestimmt dabei den Inhalt des Kombinationsfeldes (alle Rechnungen oder nur die offenen Rechnungen).

Das Unterformular „sfrmZahlbeträge-Eingang“ ist mit der RechnungsID des Hauptformlars verknüpft und nimmt die Zahlungseingänge in der Tabelle „tblZahlbeträge“ auf:

Das Hauptformlar hat in der Entwurfsansicht dieses Aussehen:



Die Rechnungsnummer wird aus den Feldern „Rechnungsjahr“ und „lfdNr“ mit folgender Formel berechnet: =Format([Rechnungsjahr];"00") & Format([lfdNr];"00000")

Option Compare Database Option Explicit Private Sub cboSuchfeld_AfterUpdate() Dim rs As Recordset Set rs = Me.RecordsetClone rs.FindFirst "RechnungsID = " & Me!cboSuchfeld Me.Bookmark = rs.Bookmark rs.Close End Sub Private Sub Form_Current() optRechnungsauswahl_Click End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 34 Or KeyCode = 33 Then 'PgDown oder PgUp KeyCode = 0 End If End Sub Private Sub cmdClose_Click() On Error GoTo Err_cmdClose_Click If Me.Tag <> "" Then DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , _ acMenuVer70 Forms![frmMahnungen]!lstMahnungen.Requery End If DoCmd.Close Exit_cmdClose_Click: Exit Sub Err_cmdClose_Click: MsgBox Err.Description Resume Exit_cmdClose_Click End Sub Private Sub optRechnungsauswahl_Click() If optRechnungsauswahl = 2 Then cboSuchfeld.RowSource = "SELECT DISTINCTROW " & _ "tblRechnung.RechnungsID, Format([Rechnungsjahr],'00') & " & _ "Format([lfdNr],'00000') AS Rechnungsnr FROM tblRechnung " & _ "WHERE (((IIf([Skontoabzug] = True, False, " & _ "IIf([Bruttobetrag] - [Zahlbetrag] <= 0, False, True))) " & _ "= True)) ORDER BY IIf([Rechnungsjahr]>90,'19' & " & _ "Format([Rechnungsjahr],'00'),'20' & " & _ "Format([Rechnungsjahr],'00')), tblRechnung.lfdNr;" Else cboSuchfeld.RowSource = "SELECT DISTINCTROW " & _ "tblRechnung.RechnungsID, Format([Rechnungsjahr],'00') & " & _ "Format([lfdNr],'00000') AS Rechnungsnr " & _ "FROM tblRechnung ORDER BY IIf([Rechnungsjahr]>90,'19' & " & _ "Format([Rechnungsjahr],'00'),'20' & " & _ "Format([Rechnungsjahr],'00')), tblRechnung.lfdNr;" End If End Sub



Anwendung starten Wie im vorigen Kapitel bereits beschrieben, werden auch in dieser Anwendung die Datentabellen automatisch in der Programmdatei eingebunden.

Die Konstante „Tabellen“, welche die Namen der einzubindenden Tabellen enthält, wird folgendermaßen deklariert: Const Tabellen = "tblAnrede,tblKunden,tblRechnung,tblRechnungsart, tblRechnungsdetails,tblReparaturtexte,tblZahlbeträge"

Das Startformular „frmStart“ übernimmt die gesamte Steuerung der Anwendung. Von ihm werden alle zur Verfügung stehenden Formulare bzw. Berichte aufgerufen:

Option Compare Database Option Explicit Private Sub cmdKunden_Click() On Error GoTo Err_cmdKunden_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmKundenEingabe" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdKunden_Click: Exit Sub Err_cmdKunden_Click: MsgBox Err.Description Resume Exit_cmdKunden_Click End Sub Private Sub cmdKundensuche_Click() On Error GoTo Err_cmdKundensuche_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmKundensuche" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdKundensuche_Click: Exit Sub



Err_cmdKundensuche_Click: MsgBox Err.Description Resume Exit_cmdKundensuche_Click End Sub Private Sub cmdRedchnungBearbeiten_Click() On Error GoTo Err_cmdRedchnungBearbeiten_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmRechnung" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdRedchnungBearbeiten_Click: Exit Sub Err_cmdRedchnungBearbeiten_Click: MsgBox Err.Description Resume Exit_cmdRedchnungBearbeiten_Click End Sub Private Sub cmdStorno_Click() On Error GoTo Err_cmdStorno_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmStorno" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdStorno_Click: Exit Sub Err_cmdStorno_Click: MsgBox Err.Description Resume Exit_cmdStorno_Click End Sub Private Sub cmdRechnungNeu_Click() On Error GoTo Err_cmdRechnungNeu_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmRechnung" DoCmd.OpenForm stDocName, , , stLinkCriteria, acFormAdd Exit_cmdRechnungNeu_Click: Exit Sub Err_cmdRechnungNeu_Click: MsgBox Err.Description Resume Exit_cmdRechnungNeu_Click End Sub Private Sub cmdClose_Click() On Error GoTo Err_cmdClose_Click DoCmd.Quit Exit_cmdClose_Click: Exit Sub Err_cmdClose_Click: MsgBox Err.Description Resume Exit_cmdClose_Click End Sub



Private Sub cmdReparaturtexte_Click() On Error GoTo Err_cmdReparaturtexte_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmReparaturtexte" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdReparaturtexte_Click: Exit Sub Err_cmdReparaturtexte_Click: MsgBox Err.Description Resume Exit_cmdReparaturtexte_Click End Sub Private Sub cmdEtiketten_Click() On Error GoTo Err_cmdEtiketten_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmEtikettenauswahl" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdEtiketten_Click: Exit Sub Err_cmdEtiketten_Click: MsgBox Err.Description Resume Exit_cmdEtiketten_Click End Sub Private Sub cmdCopyright_Click() On Error GoTo Err_cmdCopyright_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmCopyright" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdCopyright_Click: Exit Sub Err_cmdCopyright_Click: MsgBox Err.Description Resume Exit_cmdCopyright_Click End Sub Private Sub cmdZahlungseingang_Click() On Error GoTo Err_cmdZahlungseingang_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "frmZahlungseingang" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdZahlungseingang_Click: Exit Sub Err_cmdZahlungseingang_Click: MsgBox Err.Description Resume Exit_cmdZahlungseingang_Click End Sub

Microsoft Access VBA-Tools - Institut für … Access VBA-Tools Otmar Haring Seite 2...

Documents

Transcript of Microsoft Access VBA-Tools - Institut für … Access VBA-Tools Otmar Haring Seite 2...