EDV MS-Access tools adressenfelder, allgemein, datei, inhalt lesen, datei, inhalt schreiben und lesen, datei, kopieren, datei, typ ermitteln, datei, wählen, dateien auslesen, ini, dateien, existenz, dateisystem, laufwerk prüfen, datensätze kopieren, datensätze wechseln, datensicherung, dokumentenverwaltung, download begleiten, fehler, fortschritts-anzeige, größter wert, tabellenfeld, hilfe, info, leerzeichen, löschen, meldungsfenster, menüaktionen, modul: arrays, modul: listenfelder, modul: verzeichnisse rekursiv, normalisierung, normalisierung, tippfehler, protokoll, statusanzeige, stichwortlisten, tastaturbelegung anzeigen, umgebungsvariablen, verzeichnisse, verzeichnisse, datenbank, verzeichnisse, existenz, verzeichnisse, inhalt, verzeichnisse, prüfen, anlegen, verzeichnisse, rekursiv, verzeichnisse, übergeordnete, verzeichnisse, wechseln, vorlage, standard, datensätze, schleife, vorlage, standard, sub, objektvariablen, wählhilfe, zeit, funktionen, zeit, jahr 2000, y2k, zufallsgenerator

infobase: EDV - MS-Access

Tools

Tools

Adressenfelder Quelle: dmt Datum: 03.2004

AUTOMATISCHES AUSFÜLLEN der Briefanrede a'la 'Sehr geehrter Herr Mustermann' (da haben sich schon bessere Leute die Zähne dran ausgebissen) kann bewundert werden in LaserJob.mdb oder DMT.mdb.

Zusammen mit einer Vor/Nachname-Checkung, einer Tabellen-internen PLZ/Ort-Prüfung und einer Vorwahl-Hilfe (alle Anschlußfelder=NULL vgl. per PLZ, oder Vorwahl extrahieren) muß man sich fragen, ob es in einer Adressen-Anwendung dann eigentlich überhaupt noch irgendetwas auszufüllen gibt !

Vorwahl_Def in der alten Fassung mit 4 expliziten Feldern:

Private Sub Vorwahl_Def (sArt As String, sC As String)

    ' **** Vorwahl-Ergänzung ****

    Dim v As Variant
    Dim sVorwahl As String

    If Not IsNull(Me(sC)) Then              ' Wenn das Nummernfeld einen
       Exit Sub                             ' Wert enthält, erfolgt keine
    End If                                  ' Zuweisung

    ' Hier wird der Reihe nach (Nummer 1-4) geprüft, ob es sich nicht um
    ' das zuzuweisende Element handelt und ob das zu überprüfende Element
    ' auch einen Wert enthält.

    ' In diesem Fall versucht die Funktion Get_Vorwahl, die Vorwahl zu
    ' ermitteln, und es wird bei Rückgabe eines gültigen zu einer Sprung-
    ' Marke verwiesen, die den Wert der Funktion zuweist.

    ' aber zuerst werden die 'fixen' Standardvorwahlen a'la 0171- gecheckt !
    ' und zwar über ein explizites DLookup und nicht über Column(x) !!!

    v = DLookup("Standard_Vorwahl", "Adressen_Anschlüsse", "Bezeichnung='" & Me(sArt) & "'")

    If FlascheLeer(v) = False Then
       sVorwahl = v
    End If

'    If FlascheLeer(Me(sArt).Column(1)) = False Then
'       sVorwahl = Me(sArt).Column(1)
'    End If

    If sVorwahl <> "" Then GoSub Set_Vorwahl_Def

    If sC <> "Nummer 1" And Not IsNull(Me![Nummer 1]) Then
       sVorwahl = Get_Vorwahl(Me![Nummer 1])
    End If

    If sVorwahl <> "" Then GoSub Set_Vorwahl_Def

    If sC <> "Nummer 2" And Not IsNull(Me![Nummer 2]) Then
       sVorwahl = Get_Vorwahl(Me![Nummer 2])
    End If

    If sVorwahl <> "" Then GoSub Set_Vorwahl_Def

    If sC <> "Nummer 3" And Not IsNull(Me![Nummer 3]) Then
       sVorwahl = Get_Vorwahl(Me![Nummer 3])
    End If

    If sVorwahl <> "" Then GoSub Set_Vorwahl_Def

    If sC <> "Nummer 4" And Not IsNull(Me![Nummer 4]) Then
       sVorwahl = Get_Vorwahl(Me![Nummer 4])
    End If

    If sVorwahl <> "" Then
       GoSub Set_Vorwahl_Def
    Else
       Exit Sub
    End If


Set_Vorwahl_Def:

    Me(sC) = sVorwahl
    Me(sC).SetFocus

    If sVorwahl = "keine" Then
       Me(sC) = Null
    Else
       SendKeys "{F2}"
    End If

End Sub

und jetzt in der neuen Fassung innerhalb eines Unterformulares;

der Aufruf erfolgt in After_Update mittels

Vorwahl_Def Me!Art, Me!Wert

Private Sub Vorwahl_Def (C1 As Control, C2 As Control)

    ' **** Vorwahl-Ergänzung ****

    On Error GoTo err_Vorwahl_Def

    Dim RS As Recordset
    Dim v As Variant
    Dim sVorwahl As String

    ' **** Plausibilitäten ****

    If IsNull(C1) Then                  ' bei gelöschtem Art-Inhalt
       Exit Sub                         ' passiert ebenfalls nichts.
    End If

    If Not IsNull(C2) Then              ' Wenn das Nummernfeld einen
       Exit Sub                         ' Wert enthält, erfolgt keine
    End If                              ' Zuweisung.

    ' aber zuerst werden die 'fixen' Standardvorwahlen a'la 0171- gecheckt !
    ' und zwar über ein explizites DLookup und nicht über Column(x) !!!

    v = DLookup("Standard_Vorwahl", "Adressen_Anschlüsse", "Bezeichnung='" & C1 & "'")

    If FlascheLeer(v) = False Then
       sVorwahl = v
    End If

    If sVorwahl <> "" Then              ' art-bezogene Vorwahl vorhanden
       GoSub Set_Vorwahl_Def
    Else                                ' keine art-bezogene Vorwahl
       Set RS = Me.RecordSetClone
       If RS.RecordCount = 0 Then       ' beim ersten Datensatz werden
          sVorwahl = Get_PLZ_Vorwahl(Me.Parent!Plz)   ' andere Anschlussdaten mit gleicher Plz abgefragt.
       Else
          RS.MoveLast
          sVorwahl = Get_Vorwahl(RS("Wert"))
       End If
       GoSub Set_Vorwahl_Def
    End If

    Exit Sub


err_Vorwahl_Def:

    Fehler "err_Vorwahl_Def"
    Exit Sub


Set_Vorwahl_Def:

    If Len(sVorwahl) > 0 Then
       C2 = sVorwahl
    End If

    C2.SetFocus

    If sVorwahl = "keine" Then
       C2 = Null
    Else
       SendKeys "{F2}", True
    End If

End Sub

Und dann noch die Funktion, die die reine Vorwahl extrahiert:

Private Function Get_Vorwahl (v As Variant) As String

    ' **** Ermittle die Vorwahl der übergeb. Telefonnummer ****

    Dim i As Integer, iAsc As Integer

    ' akzeptiert wird jedes Trennzeichen <> ANSI 48-57

    If IsNull(v) Then
       Exit Function
    End If

    For i = 1 To Len(v) - 1

        iAsc = Asc(Mid$(v, i, 1))

        If iAsc < 48 Or iAsc > 57 Then

           If i = 1 Or i = Len(v) Then
              Beep
              MsgBox "Ungültiges Telefonnummer-Format für '" & v & "'.", 16, "Form Adressen / Get_Vorwahl"
              Exit Function
           Else
              Get_Vorwahl = Left$(v, i)
              Exit Function
           End If

        End If

    Next i

End Function


Private Function Get_PLZ_Vorwahl (vPlz As Variant) As String

    On Error GoTo err_Get_PLZ_Vorwahl

    ' ermittle für die angegebene Plz Telefonnummern der Arten Telefon, Geschäft, privat und Fax.

    If Not IsNull(vPlz) Then

       Dim sSQL As String
       Dim DB As Database, RS As Recordset

       sSQL = "SELECT Adressen_Kommunikation.Art, Adressen_Kommunikation.Wert FROM Adressen "
       sSQL = sSQL & "INNER JOIN Adressen_Kommunikation ON Adressen.Suchname = Adressen_Kommunikation.Suchname "
       sSQL = sSQL & "WHERE ((Adressen_Kommunikation.Art='Telefon' Or Adressen_Kommunikation.Art='Geschäft' Or "
       sSQL = sSQL & "Adressen_Kommunikation.Art='Privat' Or Adressen_Kommunikation.Art='Fax') AND "
       sSQL = sSQL & "(Adressen.Plz=" & vPlz & "));"

       Set DB = DBengine.Workspaces(0).Databases(0)
       Set RS = DB.OpenRecordset(sSQL)

       If Not RS.EOF Then
          Get_PLZ_Vorwahl = Get_Vorwahl(RS("Wert"))
       End If

    End If

    Exit Function


err_Get_PLZ_Vorwahl:

    Fehler "Get_PLZ_Vorwahl"
    Exit Function

End Function

allgemein Quelle: dmt Datum: 03.2004

TOOLS / UTILITIES / STANDARDROUTINEN:

Was wären wir Programmierer ohne diese kleinen Helfer, die manchmal sogar unseren Windows/Access-Alltag verschönern können ?

Datei, Inhalt lesen Quelle: dmt Datum: 03.2004

DATEIINHALT einlesen:

Für Dateien mit Zeilenumbrüchen kann folgende Funktion benutzt werden:

Function ReadFileWithCRIntoString(sDatei As String) As String

    On Error GoTo err_ReadFileWithCRIntoString

    Dim FF As Integer, s As String, sInhalt As String

    ' Einlesen einer vollständigen Datei mit Zeilenumbrüchen in einen String incl. Rückgabe

    FF = FreeFile

    Open sDatei For Input As #FF

    Do While Not EOF(FF)
       Line Input #FF, s
       sInhalt = sInhalt & s & vbCrLf
    Loop

    Close #FF

    ReadFileWithCRIntoString = TotalTrim(sInhalt)

    Exit Function


err_ReadFileWithCRIntoString:

    Fehler "ReadFileWithCRIntoString"
    Exit Function

End Function

Datei, Inhalt schreiben und lesen Quelle: dmt Datum: 03.2005

DATEI mit gegebenem Inhalt schreiben:

Function WriteFileByString(sFile As String, sContent As String) As Boolean

    On Error GoTo err_WriteFileByString

    Dim FF As Integer

    ' Schreiben einer vollständigen Datei mit dem Inhalt des übergebenen Strings incl. Erfolgs-Rückgabe

    FF = FreeFile

    Open sFile For Output As #FF
        Print #FF, sContent
    Close #FF

    WriteFileByString = True

    Exit Function


err_WriteFileByString:

    Fehler "WriteFileByString"
    Exit Function

End Function

oder einen Datei-Inhalt als Variable zurückgeben:

Da größere Inhalte (>22kB) bei String-Variablen und selbst als Variant-Funktions-Rückgabewerte öfters Probleme bereiten, werden die Inhalte in den folgenden beiden Prozeduren per Referenz zurückgegeben.

Zeilenweises Lesen:

Function GetFileContentByLines (sFile As String, vReturn As Variant) As Integer

    ' **** Der zeilenweise gelesene Dateiinhalt wird per Referenz zurückgegeben, da die          ****
    ' **** Funktion selbst als Variant größere Zeichenketten (z.B. 48kB) nicht zurückgeben kann. ****

    On Error GoTo err_GetFileContentByLines

    Dim FF As Integer, vTotal As Variant, vLine As Variant

    FF = FreeFile

    Open sFile For Input As FF
        Do While Not EOF(FF)
           Line Input #FF, vLine
           vTotal = vTotal & vLine & Chr$(13) & Chr$(10)
        Loop

    GetFileContentByLines = True


exit_GetFileContentByLines:

    Close FF
    Exit Function


err_GetFileContentByLines:

    If Err = 53 Then
       Beep
       MsgBox "Die Datei '" & sFile & "' konnte nicht gefunden werden !", 16, "GetFileContentByLines"
    Else
       Fehler "GetFileContentByLines"
    End If

    Resume exit_GetFileContentByLines

End Function

Binäres Einlesen mit Aufruf einer Zusatzfunktion, die die Access2-Basic-Hürde überwindet, da dort Dateieigenschaften nur rudimentär ermittelt werden können.

Function GetFileContentBinary (sFile As String, vReturn As Variant) As Integer

    ' **** Der binär gelesene Dateiinhalt wird per Referenz zurückgegeben, da die Funktion ****
    ' **** selbst als Variant größere Zeichenketten (z.B. 48kB) nicht zurückgeben kann.    ****

    On Error GoTo err_GetFileContentBinary

    Dim FF As Integer, vTotal As Variant, vLine As Variant

    FF = FreeFile

    Open sFile For Input As FF

    vReturn = Input(Get_FileProperty(sFile, "Größe"), #FF)

    GetFileContentBinary = True


exit_GetFileContentBinary:

    Close FF
    Exit Function


err_GetFileContentBinary:

    If Err = 53 Then
       Beep
       MsgBox "Die Datei '" & sFile & "' konnte nicht gefunden werden !", 16, "GetFileContentBinary"
    Else
       Fehler "GetFileContentBinary"
    End If

    Resume exit_GetFileContentBinary

End Function

Datei, kopieren Quelle: dmt Datum: 03.2004

DATEIEN in Windows 3.x KOPIEREN:

Auch das Kopieren von Dateien ist per API-Aufrufe möglich, allerdings ist es bisher noch nicht gelungen, Dateien zu kopieren, die bereits in Benutzung sind. Eventuell muß noch mit den OpenParametern gespielt werden -> hat auch nichts gebracht, naja, aber immerhin kann man damit 'unberührte' Dateien windows-konform kopieren.

Im Deklarationsteil eines Modules steht:

Type OFSTRUCT
    cBytes As String * 1
    fFixedDisk As String * 1
    nErrCode As Integer
    reserved As String * 4
    szPathName As String * 128
End Type

Declare Sub LZClose Lib "LZexpand.dll" (ByVal hWnd As Integer)
Declare Function LZCopy Lib "LZexpand.dll" (ByVal hfSource As Integer, ByVal hfDest As Integer) As Long
Declare Function LZOpenFile Lib "LZexpand.dll" (ByVal lpszFile As String, lpOf As OFSTRUCT, ByVal style As Integer) As Integer

und hier die Subroutine, die sogar ein bißchen was kann:

Function API_CopyFile (vQuelle As Variant, vZiel As Variant, iQuiet As Integer)

    On Error GoTo err_API_CopyFile

    Dim OFSTRUCT_Quelle As OFSTRUCT, OFSTRUCT_Ziel As OFSTRUCT
    Dim hWndQuelle As Integer, hWndZiel As Integer, lRet As Long
    Dim sQuelle As String, sZiel As String

    Const OF_READ = &H0
    Const OF_CREATE = &H1000

    ' **** Plausibilitäten ****

    If IsNull(vQuelle) Then
       Beep
       MsgBox "Es wurde keine Quelldatei übergeben !", 16, "API_CopyFile"
       Exit Function
    ElseIf IsNull(vZiel) Then
       Beep
       MsgBox "Es wurde keine Zieldatei übergeben !", 16, "API_CopyFile"
       Exit Function
    End If

    sQuelle = LCase(vQuelle)
    sZiel = LCase(vZiel)

    ' **** Öffnen, Kopieren und Schließen ****

    Meldung "Kopiere " & Get_FileName(sQuelle)

    hWndQuelle = LZOpenFile(sQuelle, OFSTRUCT_Quelle, OF_READ)    ' Quelldatei öffnen
    hWndZiel = LZOpenFile(sZiel, OFSTRUCT_Ziel, OF_CREATE)        ' Zieldatei öffnen

    lRet = LZCopy(hWndQuelle, hWndZiel)                           ' Datei kopieren

    LZClose hWndQuelle                                            ' Quelldatei schließen
    LZClose hWndZiel                                              ' Zieldatei schließen

    Meldung ""

    ' **** Auswertung ****

    If lRet < 0 Then                                              ' Fehler aufgetreten
       Beep
       MsgBox "Fehler beim Kopieren: " & lRet, 16, "API_CopyFile"
    Else
       If Not iQuiet Then                                        ' Meldung erwünscht ?
          Beep
          MsgBox "Die Datei '" & sZiel & "' wurde mit " & lRet & " Bytes kopiert !", 64, "API_CopyFile"
       End If
       API_CopyFile = lRet
    End If

    Exit Function


err_API_CopyFile:

    Fehler "API_CopyFile"
    Exit Function

End Function

Nicht die zum implementierten Aufruf von Get_Filename gehörende Funktion vergessen !

Datei, Typ ermitteln Quelle: dmt Datum: 03.2004

Den DATEITYP ermitteln:

Function Get_Filetype(v As Variant) As Variant

    Dim iPos As Integer

    If IsNull(v) Then Exit Function

    iPos = LastInStr(CStr(v), ".")

    Get_Filetype = Right(v, Len(v) - iPos)

End Function

Beispiel:

    If Get_Filetype(Me!Dateiname.OldValue) <> Get_Filetype(Me!Dateiname) Then
       Cancel = True
       Beep
       MsgBox "Sie dürfen den Dateityp nicht verändern !", vbCritical, "Bilddatei umbenennen"
       RunCommand acCmdUndo
       Exit Sub
    End If

Datei, wählen Quelle: dmt Datum: 03.2004

DATEI-DIALOG / GETFILENAME / FILEOPENNAME:

Was hat das Nerven gekostet, zumal die Funktionen der commdlg.dll offensichtlich in Basic nicht nachgebildet werden können, da geheimnisvolle CallBack-Funktionen bisher in VB nicht zu finden waren bzw. nur in Sprachen wie C realisiert werden können. Die diversen Routinen, die in den Wizard-mda-Dateien vereinzelt zu finden waren und die sich auf eine vorgeschaltete 'msau200.dll' beziehen, konnten irgendwann doch so hingebogen werden, daß man damit etwas anfangen kann.

Hier eine Zusammenfassung der SDK-Informationen zu den Elementen der OPENFILENAME-Struktur, die den Datei-Dialogen zugrundeliegt:

Alle String-Variablen müssen scheinbar chr$(0)-null-terminiert sein.

lStructSize Struktur-Länge (Input)
hwndOwner Identifiziert Owner-Window -> Dialog als gebunden und modal, muß gesetzt werden, wenn OFN_SHOWHELP benutzt wird. 0 = eigener, ungebundener Task (Input)
hInstance Identifiziert Datenblock, der das 'dialog box template' 'lpTemplateName' enthält. Nur nötig, wenn OFN_ENABLETEMPLATE oder OFN_ENABLETEMPLATEHANDLE gesetzt sind. (Input)
lpstrFilter Zeichenkette (Input). Enthält ein oder mehrere Paare wie folgt:
'Datenbanken (*.mdb)|*.mdb|Textdateien|*.txt;*.inf;*.ini|Alle Dateien (*.*)|*.*||'
lpstrCustomFilter no Bock
nMaxCustFilter no Bock
nFilterIndex Index für Default-Filter. 1 = erster (Input)
lpstrFile Rückgabe von Pfad- und Dateinamen
nMaxFile no Bock
lpstrFileTitle Rückgabe von Dateinamen und -extension
nMaxFileTitle Größe von lpstrFileTitle
lpstrInitialDir Default-Verzeichnis; akt. Verzeichnis, wenn leer. Eine Pfadangabe im vorab gesetzten lpstrFile hat Vorrang.
lpstrTitle Dialogtitel

Flags Definiert Dialog-Erscheinungsbild sowie -verhalten

OFN_ALLOWMULTISELECT Yes ! Rückgabe in lpstrFile a'la 'c:\files file1.txt file2.txt ..\bin\file3.txt'
OFN_CREATEPROMPT Meldung, wenn Datei nicht existiert, evtl. Dialog 'Datei anlegen'. Setzt OFN_PATHMUSTEXIST und OFN_FILEMUSTEXIST Flags.
OFN_ENABLEHOOK no Bock
OFN_ENABLETEMPLATE Benutze Angaben in hInstance und lpTemplateName
OFN_ENABLETEMPLATEHANDLE no Bock
OFN_EXTENSIONDIFFERENT wird rückgebenderweise gesetzt, wenn lpstrDefExt gesetzt wurde und der Anwender eine Auswahl bestätigt, deren explizite Extension von lpstrDefExt abweicht.
OFN_FILEMUSTEXIST Warnung bei ungültigem Dateinamen. Setzt auch OFN_PATHMUSTEXIST.
OFN_HIDEREADONLY Unterdrückt 'schreibgeschützt'-Häkchen-Feld
OFN_NOCHANGEDIR Dialog ändert aktuelles Arbeitsverzeichnis nicht
OFN_NOREADONLYRETURN Zurückgegebene Datei wird kein ro-Attribut besitzen und nicht in einem schreibgeschützten Verzeichnis stehen.
OFN_NOTESTFILECREATE no Bock
OFN_NOVALIDATE Dateiname-Rückgabe wird nicht überprüft
OFN_OVERWRITEPROMPT Meldung 'Überschreiben ...' bei 'Speichern unter'-Dialog
OFN_PATHMUSTEXIST Warnung bei ungültigem Pfad
OFN_READONLY Bestimmt, ob Häkchen gesetzt werden soll und auch, wie Häkchen eingestellt wurde.
OFN_SHAREAWARE erlaubt Dateinamen-Rückgabe auch bei Share-Verletzung

Rückgabe-Werte:

OFN_SHAREFALLTHROUGH Dateiname wurde zurückgegeben
OFN_SHARENOWARN keine weitere Aktion
OFN_SHAREWARN Standard-Meldung anzeigen

OFN_SHOWHELP zeigt Hilfe-Button; hWndOwner muß gesetzt sein.

nFileOffset Dateiname steht in "c:\dir1\dir2\file.ext" an 13. Stelle; 0-basierend
nFileExtension dito für Extension
lpstrDefExt wird angehängt, wenn Anwender keine Extension angibt.
lCustData no Bock
lpfnHook no Bock
lpTemplateName no Bock

Für kleine Standardaufgaben könnte ein Einzeiler, der nur die wichtigsten Parameter setzt, genügen. Die aufgerufene Routine braucht wahrscheinlich ByVal-Parameter.

Aber sinnvoller scheint das Deklarieren der GETFILENAMEINFO-Struktur und Setzen der gewünschten Eigenschaften zu sein, weil übersichtlicher und flexibler. Allerdings dürfen String-Zuweisungen nicht NULL enthalten, siehe StringNotNull()

* * * *

Im Deklarationsteil steht:

Type GETFILENAMEINFO
    hwndOwner As Integer
    szFilter As String * 255
    szCustomFilter As String * 255
    nFilterIndex As Long
    szFile As String * 255
    szFileTitle As String * 255
    szInitialDir As String * 255
    szTitle As String * 255
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    szDefExt As String * 255
End Type

Declare Function API_GetFileName Lib "MSAU200.DLL" Alias "#1" (gfni As GETFILENAMEINFO, ByVal fOpen As Integer) As Long
Declare Function CommDlgExtendedError Lib "commdlg.dll" () As Long

und die Funktionen selbst (die Dreiteiligkeit sieht verwirrend aus, hat sich aber bewährt):

Der Aufruf kann aussagekräftig wie folgt aussehen:

sUpdateFile = GetFileName("Datei nicht gefunden", "a:\", "Update/Setup|update.*||", 1)

Der Reihe nach abgearbeitet werden die Funktionen GetFileName, GetFileName1 und
GetFileName2:

Function GetFileName (sTitle As String, sDir As String, sFilter As String, iIndex As Integer) As String

    ' **** Einstellungen vornehmen ****

    Dim ofn As GETFILENAMEINFO

    Const HIDEREADONLY = &H4
    Const FILEMUSTEXIST = &H1000
    Const SHAREAWARE = &H4000

    Const DEFFLAGS = SHAREAWARE Or FILEMUSTEXIST Or HIDEREADONLY

    ofn.hwndOwner = GetActiveWindow()
    ofn.szTitle = sTitle
    ofn.szInitialDir = sDir
    ofn.szFilter = sFilter  ' "Datenbanken (*.mdb)|*.mdb|Alle Dateien (*.*)|*.*||"
    ofn.nFilterIndex = iIndex
    ofn.Flags = DEFFLAGS
    GetFileName = LCase(GetFileName1(ofn))

End Function


Function GetFileName1 (ofn As GETFILENAMEINFO) As String

    On Error GoTo err_GetFileName1

    ' **** Hier wird lediglich GetFileName2 aufgerufen, und ****
    ' **** evtl. auftretende commdlg.dll.Fehler gemeldet    ****

    ' **** Fehler-Rückgabewerte von COMMDLG.DLL ****

    Const NOERROR = 0
    Const DIALOGFAILURE = &HFFFF
    Const GENERALCODES = &H0
    Const STRUCTSIZE = &H1
    Const initialization = &H2
    Const NOTEMPLATE = &H3
    Const NOHINSTANCE = &H4
    Const LOADSTRFAILURE = &H5
    Const FINDRESFAILURE = &H6
    Const LOADRESFAILURE = &H7
    Const LOCKRESFAILURE = &H8
    Const MEMALLOCFAILURE = &H9
    Const MEMLOCKFAILURE = &HA
    Const NOHOOK = &HB

    Const REGISTERMSGFAIL = &HC

    Dim s As String

    If (GetFileName2(ofn, True) = 0) Then

        GetFileName1 = Trim$(StringFromAPI(ofn.szFile))

    Else

        ' **** Dialog-Abbruch oder -Fehler ****

        GetFileName1 = ""

        Select Case CommDlgExtendedError()
            Case NOERROR:           Exit Function
            Case DIALOGFAILURE:     s = "DIALOGFAILURE"
            Case GENERALCODES:      s = "GENERALCODES"
            Case STRUCTSIZE:        s = "STRUCTSIZE"
            Case initialization:    s = "initialization"
            Case NOTEMPLATE:        s = "NOTEMPLATE"
            Case NOHINSTANCE:       s = "NOHINSTANCE"
            Case LOADSTRFAILURE:    s = "LOADSTRFAILURE"
            Case FINDRESFAILURE:    s = "FINDRESFAILURE"
            Case LOADRESFAILURE:    s = "LOADRESFAILURE"
            Case LOCKRESFAILURE:    s = "LOCKRESFAILURE"
            Case MEMALLOCFAILURE:   s = "MEMALLOCFAILURE"
            Case MEMLOCKFAILURE:    s = "MEMLOCKFAILURE"
            Case NOHOOK:            s = "NOHOOK"
            Case REGISTERMSGFAIL:   s = "REGISTERMSGFAIL"
        End Select

        Beep
        MsgBox "Fehler '" & s & "' in Commdlg.dll.", 16, "GetFileName1"

    End If

    Exit Function


err_GetFileName1:

    Fehler "GetFileName1"
    Exit Function

End Function


Function GetFileName2 (gfni As GETFILENAMEINFO, ByVal fOpen As Integer) As Long

    ' **** Von hier aus wird die MSAU200.DLL angesteuert ****
    ' **** Alle Strings werden vorher chr$(0)-terminiert ****
    ' **** und nach wieder ent-terminiert                ****

    Const SYSCMD_CLEARHELPTOPIC = 11

    Dim lRet As Long
    Dim unused As Variant

    gfni.szFilter = StringToAPI(gfni.szFilter)
    gfni.szCustomFilter = StringToAPI(gfni.szCustomFilter)
    gfni.szFile = StringToAPI(gfni.szFile)
    gfni.szFileTitle = StringToAPI(gfni.szFileTitle)
    gfni.szInitialDir = StringToAPI(gfni.szInitialDir)
    gfni.szTitle = StringToAPI(gfni.szTitle)
    gfni.szDefExt = StringToAPI(gfni.szDefExt)

    unused = SysCmd(SYSCMD_CLEARHELPTOPIC)
    lRet = API_GetFileName(gfni, fOpen)

    gfni.szFilter = StringFromAPI(gfni.szFilter)
    gfni.szCustomFilter = StringFromAPI(gfni.szCustomFilter)
    gfni.szFile = StringFromAPI(gfni.szFile)
    gfni.szFileTitle = StringFromAPI(gfni.szFileTitle)
    gfni.szInitialDir = StringFromAPI(gfni.szInitialDir)
    gfni.szTitle = StringFromAPI(gfni.szTitle)
    gfni.szDefExt = StringFromAPI(gfni.szDefExt)

    GetFileName2 = lRet

End Function

* * * *

Geänderte DLL-Deklarationen:

In den Windows-32-Bit-Umgebungen haben sich dll-Deklarationen verändert:

Declare Function GetActiveWindow Lib "User32.dll" () As Long

* * * *

DATEI ÖFFNEN:

eine fast unendliche Geschichte, die letztendlich per API-Datei-Dialog doch
gelöst werden konnte. Allerdings wird der Traum von einem einzeiligen Aufruf der
API-Funktion doch nicht wahr, da ein zurückgegebenes "" (NICHT Null) ein 'Wert
kann nicht gesetzt werden' erzeugt.

Sub pb_Word_Click ()

    Dim s As String

    s = LCase(API_GetFileName("Word-Programmdatei bestimmen", "c:\", "Programme (*.exe)|*.exe|" + "Alle Dateien (*.*)|*.*|" + "|", 1))

    If s <> "" Then
       Me!Word = s
    End If

End Sub

Nicht vergessen, den hWnd-Handle zu übergeben, sonst wird der Datei-Öffnen-Dialog aus der MSAU200.DLL nicht als gebundener System-Modal-Dialog, sondern als eigener Task ausgeführt. Der Anwender kann auf das im Hintergrund sichtbare Access klicken und damit den Dialog verdecken.
Versucht man darauf hin, die Access-Anwendung zu schließen, hängt sich Access auf !

* * * *

Eine Schwarzenegger-Version von TotalTrim, die hier als StringFromAPI in Erscheinung tritt, bekämpft Probleme, die 2003 unter NT4 auftraten.

Dort wurde der API-String, der Pfad und Name einer gewählten Datei enthielt, von rechts gesehen mit einem Blank, einem Zeilenumbruch und weiteren Blanks abgeschlossen. Von chr$(0) keine Spur.

Private Function StringFromAPI (sString As String) As String

    On Error GoTo err_StringFromAPI

    Dim iPos As Integer, s As String, DOS_CR As String

    s = Trim$(sString)                                          ' Ein Trim vorneweg
    DOS_CR = Chr$(13) & Chr$(10)

    If Left$(s, 2) = DOS_CR Then s = Mid$(s, 2)                 ' führendes CR entfernen
    If Right$(s, 2) = DOS_CR Then s = Left$(s, Len(s) - 2)      ' abschließendes CR entfernen

    Do While Left$(s, 1) = Chr$(0)                              ' führende chr$(0) entfernen
       s = Trim$(Right$(s, Len(s) - 1))
    Loop

    iPos = InStr(s, Chr$(0))                                    ' abschließende chr$(0) entfernen

    If iPos > 0 Then
       s = Left$(s, iPos - 1)
    End If

    StringFromAPI = Trim$(s)                                    ' Ein Trim hinterher

    Exit Function


err_StringFromAPI:

    Fehler "StringFromAPI"
    Exit Function

End Function

Dateien auslesen, ini Quelle: dmt Datum: 03.2004

Das Auslesen von EINTRÄGEN in INI-Dateien ist auch nicht immer zum Lachen.

Das Herumärgern mit GetProfileString (auch mit VB-Beispielen) hat nicht zum Erfolg geführt. Anders sieht das aber mit GetPrivateProfileString aus, das mit API_GetIniString handhabbar gemacht werden konnte.

So liefert ein API_GetIniString("boot.description", "display.drv", "system.ini") folgendes:

ATI mach64: 640x480x32k (Small Font)

Allerdings gibt es für das Problem des Ermittelns der aktuellen Bildschirm-Auflösung bereits viel bessere Lösungen. s.a. CenterForm

Selbst selbstgeschriebene DOS-ASCII-Dateien, die einigermaßen ini-mäßig drauf sind, lassen sich somit problemlos auslesen.

Function API_GetIniString (sSection As String, sKey As String, sIniFile As String) As String

    ' **** Inidatei im WinDir, wenn keine Pfadangabe ****

    ' Bsp.:     API_GetIniString("boot.description", "display.drv", "system.ini")
    ' liefert:  ATI mach64: 640x480x32k (Small Font)

    Dim sRet As String, iRet As Integer

    sRet = String$(255, 0)

    iRet = GetPrivateProfileString(sSection, sKey, "", sRet, Len(sRet), sIniFile)

    If iRet > 0 Then
        API_GetIniString = Left(sRet, iRet)
    End If

End Function

Voraussetzung ist folgende Deklaration:

Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer

Wenn es beim Kopieren der Deklaration Ärger gibt, dann aus anderen Modulen übernehmen !

Eine weitere Hürde zwischen den Erläuterungen im SDK.HLP sind die Notationen / Syntax:

DCX_LOCKWINDOWUPDATE  0x00000400L                  in Win-Api bedeutet
Global Const DCX_LOCKWINDOWUPDATE = &H00000400&    in Basic !

SPIF_SENDWININICHANGE  0x0002                      API
Global Const SPIF_SENDWININICHANGE = &H0002        Basic

SPI_GETMENUDROPALIGNMENT  27                       API
Global Const SPI_GETMENUDROPALIGNMENT = 27         Basic

Erläuterungen zu den angegebenen Variablentypen in 'C' finden sich auch im KnowHow-Text zu Basic-Konventionen.

Dateien, Existenz Quelle: dmt Datum: 05.2004

DATEIEN AUF EXISTENZ prüfen:

Überprüfungen, ob Dateien auch wirklich angekommen sind, gehen am einfachsten a'la:

s = TempPfad & "\" & UPDATEFILE

If InStr(s, Dir$(s)) Then

, da eine Dateivariable sicherheitshalber den kompletten Pfad enthalten sollte und der Vergleich mit Dir$(s) aber nur den reinen Dateinamen ohne Pfad zurückgibt.

* * * *

Sehr einfach, lohnt sich nicht mal, eine echte Funktion zu schreiben:

Dir$("e:\windows\system.ini") <> ""

Auch Wildcards sind zulässig, SCHEITERT aber, wenn die Datei-Namen nicht der 8.3-Konvention entsprechen.

* * * *

Als Funktion sieht das dann so aus (kommt mittlerweile auch mit so Scheiße wie "c:\Eigene Dateien\...") zurecht (leider nur im Pfadnamen, NICHT aber im Dateinamen.

Somit kann diese leicht aufgebohrte Fassung nicht bedenkenlos in 32-Bit-Umgebungen eingesetzt werden ! (siehe GetFileAttributes(); auch die zweite Version von Exists_File dort beachten!):

Function Exists_File (sFile As String) As Integer

    On Error GoTo err_Exists_File

    Dim sDir As String

    sDir = Dir$(sFile)

    If InStr(LCase(sFile), LCase(Dir$(sFile))) And Len(sDir) > 0 Then
       Exists_File = True
    End If

    Exit Function


err_Exists_File:

    Fehler "Exists_File"
    Exit Function

End Function

Hier sogar mit ein paar Gimmicks:

    sFile = Dir$(sImportPattern)

    If sFile <> "" Then                             ' Datei gefunden
       Do
          If sFile = UPDATE_FILE Then               ' Paket-Datei
             ' übergehen
          ElseIf sFile = Database_Filename() Then   ' transact.mdb
             iUpdateTransact = True
          Else
             'MsgBox sImportDir & "\" & sFile & "  " & sDatabaseDir & "\" & sFile    ' Dateinamen anzeigen
             If API_CopyFile(sImportDir & "\" & sFile, sDatabaseDir & "\" & sFile, True) = False Then
                iCopySuccess = False
             End If
          End If
          sFile = Dir$                              ' nächste Datei suchen
       Loop Until sFile = ""                        ' weitermachen
    Else
        Beep
        MsgBox "Das Verzeichnis " & sImportDir & " ist leer !", 16, "Ende_Setup_Check_ImportFiles"
    End If

Die erste Anweisung Dir$(xyz) liefert das erste Ergebnis, in der Schleife wird mit String=Dir dieses Suchmuster solange weiter tradiert, bis die Abbruchbedingung

Len(Ergebnis)>0

oder auch

Ergebnis<>""

erfüllt ist.

Problematisch wird es, wenn auf der Basis gefundener Dateien eine weitere Dir-Anweisung Quervergleiche in anderen Verzeichnissen anstellen soll. Das setzt auf JEDEN Fall das Suchmuster der ersten Dir-Geschichte ausser Kraft, auch wenn das zweite GeDIRre in einer anderen Routine stattfindet. Hier muß, um nicht mit komisch agierenden Arrays in die Quere zu kommen, wohl am besten mit temp-Dateien gearbeitet werden, die anschließend wieder ausgelesen werden müssen oder wie vor 20 Jahren, mit Basic-DATA-Anweisungen.

Was haben wir gelacht ...

* * * *

GetFileAttributes(sDateiName)

oder auch: lange Dateinamen im Griff, letztendlich gibt es mit 16-Bit-Umgebungen wie Access 2.0 unter 32-Bit-Systemen eben doch ab und zu mal Probleme.

Eine kernel32-Deklaration sieht so aus:

Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long

Unter Win95c wollte kernel32.* nicht gefunden werden, aber ein vereinfachtes

Declare Function GetFileAttributes Lib "kernel" (ByVal lpFileName As String) As Long

konnte helfen.

Bei nicht vorhandener Datei wird -1 zurückgegeben, ein Positiv-Vergleich gegen

> 0

ist ein Zeichen für die Existenz der angegebenen Datei.

Die Funktion Exists_File sieht die Funktion, die sowohl unter Win9x wie auch NT läuft, so aus:

Declare Function GetFileAttributes9x Lib "kernel" Alias "GetFileAttributes" (ByVal lpFileName As String) As Long
Declare Function GetFileAttributesNT Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long

Function Exists_File (sFile As String) As Integer

    On Error Resume Next

    ' **** das läuft hier anders, als sonst ...                                                     ****
    ' **** Um nicht mit langen Katalognamen zu kollidieren, wird auf eine API-Funktion ausgewichen. ****
    ' **** Leider muß zwischen den Betriebssystem-Welten Windows 9x und NT unterschieden werden.    ****

    Dim iRet As Integer

    If GetFileAttributes9x(sFile) > 0 Then
       iRet = True
    End If

    If GetFileAttributesNT(sFile) > 0 Then
       iRet = True
    End If

    Exists_File = iRet

End Function

Dateisystem, Laufwerk prüfen Quelle: dmt Datum: 03.2004

Ermitteln eines Laufwerkbuchstabens, auf dem sich ein Referenzverzeichnis befinden soll:

Function Get_DataDrive () As String

    On Error GoTo err_Get_DataDrive

    ' **** da diese Anwendung unter verschiedenen Windowsen läuft, kommt es vor, daß    ****
    ' **** verschiedene Partitionen unter verschiedenen Laufwerksbuchstaben erscheinen. ****

    ' Als Datenpartition wird die erste angesehen, auf der das Verzeichnis websites gefunden werden kann.

    Dim sDriveLetter As String

    Const REFDIR = "websites"

    sDriveLetter = "i"
    GoSub Get_DataDrive_RefDir

    sDriveLetter = "m"
    GoSub Get_DataDrive_RefDir

    Beep
    MsgBox "Das Datenlaufwerk, das das Verzeichnis '" & REFDIR & "' enthält, konnte nicht bestimmt werden !", 16, "Get_DataDrive"

    Exit Function


Get_DataDrive_RefDir:

    ChDrive sDriveLetter & ":"
    ChDir REFDIR
    If Dir(sDriveLetter & ":\" & REFDIR & "\*.*") <> "" Then
       Get_DataDrive = sDriveLetter
       Exit Function
    End If
    Return


err_Get_DataDrive:

    If Err = 68 Then
       Beep
       MsgBox "Das Laufwerk " & sDriveLetter & ": ist nicht verfügbar !", 16, "Get_DataDrive"
    ElseIf Err = 76 Then
       ' Verzeichnis nicht gefunden, weitermachen
       Resume Next
    Else
       Fehler "Get_DataDrive"
    End If

    Exit Function

End Function

Datensätze kopieren Quelle: dmt Datum: 03.2004

Oft ist eine Routine, die alle Felder eines Recordsets an ein Zielrecordset übergibt, hilfreich.
Aber wehe, wenn ein OLE-Feld im Spiel ist. Ich habe es vorgezogen, für diesen Fall das Problem per SQL-Statement zu lösen.

Sub Kopiere_Datensatz (RSQ As Recordset, RSZ As Recordset)

    ' stammt urspr. aus Modul Ventile/Copy_Valve_Data
    ' Für alle Quell-Felder werden an das Zielfeld, das
    ' seine Namenszuweisung durch 'RSQ(c).Name' erhält,
    ' die Inhalte der entsprechenden Quellfelder 'RSQ(c)
    ' zugewiesen.

    On Error GoTo err_Kopiere_Datensatz

    Dim c As Integer, O As Object

    For c = 0 To RSQ.Fields.Count - 1
        RSZ(RSQ(c).Name) = RSQ(c)
    Next c

    Exit Sub


err_Kopiere_Datensatz:

    Fehler "Kopiere_Datensatz"
    Exit Sub

End Sub

Datensätze wechseln Quelle: dmt Datum: 05.2006

JUMPTO und JUMPBACK:

ermöglichen auch in komplexen Formularsituationen den info- oder Neueingabe-Sprung aus einer bestimmten Bearbeitungssituation heraus zum gewünschten Ziel und danach wieder zurück.

Der automatische Fallback beim Eintreten diverser Ereignisse führt zu klassischen Problemen (gegenseitiges Auslösen von Ereignissen). Deswegen reduzieren wir den Rücksprung-Auslöser auf eine eigens eingeblendete Symbolleisten-Schaltfläche. Der Versuch der Manipulation der Eigenschaft 'MenuBar' führte zu schweren Darstellungsfehlern und Schutzverletzungen. Aber für Mausmuffel kann thematisch an das klassische <Strg+z> für Rückgängig angelehnt ein <Strg+Shift+z> angeboten werden.

Das Tool beherrscht sogar so spleenige Fälle wie Schließen des Herkunftsformulares, wenn's sein muß sogar nach erfolgter Neueingabe. JumpBack wird's schon richten ...

Voraussetzungen:

In einem eigenen Modul werden Typ, eine globale Typvariable für formularübergreifende Sprünge sowie die beiden Sprungroutinen vereinbart:

' **** Deklaration des Jumpdatentyps sowie der globalen Variable ****

Type JumpType

    sAction As String
    iCurrentView As Integer
    sIdentFeld As String
    vIdentWert As Variant
    sHerkunftsFormular As String
    sHerkunftsFeld As String
    vHerkunftsWert As Variant
    sZusatzdaten As String
    sZusatzdatenFeld As String
    sZielFormular As String
    sZielFeld As String
    vZielWert As Variant

End Type

Global gJump As JumpType


Sub JumpTo (sAction As String, sZielFormular As String, sZielFeld As String, vZielWert, sIdentFeld As String, vIdentWert As Variant)

    ' **** Sprung von einer beliebigen Stelle zu einem bestimmten ****
    ' **** Formular und Datensatz mit späterer Rückkehrmöglichkeit****

    On Error GoTo err_JumpTo

    DoCmd Hourglass True

    ' **** Objektvariablen deklarieren und zuweisen ****

    Dim SAF As Form, SAC As Control, CZielfeld As Control

    Set SAF = Screen.ActiveForm
    Set SAC = Screen.ActiveControl
    Set CZielfeld = Forms(sZielFormular)(sZielFeld)

    ' **** und los gehts ****

    If gJump.sAction <> "" Then
       Beep
       MsgBox "Eine Sprungverschachtelung ist in dieser Programmversion nicht zulässig !", 16, "JumpTo"
       GoSub exit_JumpTo
    End If

    ' **** Werteübergabe an globale Datentyp-Variable gJump ****

    gJump.sAction = sAction
    gJump.iCurrentView = SAF.CurrentView
    gJump.sIdentFeld = sIdentFeld
    gJump.vIdentWert = vIdentWert
    gJump.sHerkunftsFormular = SAF.Name
    gJump.sHerkunftsFeld = SAC.Name
    gJump.vHerkunftsWert = vZielWert
    gJump.sZielFormular = sZielFormular
    gJump.sZielFeld = sZielFeld
    gJump.vZielWert = vZielWert

    ' **** evtl. Zusatzformular hinterlegen und ausblenden ****

    If gJump.sHerkunftsFormular = "Adressen" Then
       If Forms!Adressen!UF_Zusatzdaten.Visible = True Then
          gJump.sZusatzdaten = Forms!Adressen!UF_Zusatzdaten.SourceObject
          gJump.sZusatzdatenFeld = SAC.Name
          Forms!Adressen!Suchname.SetFocus
       End If
    End If

    ' **** Darstellung abschalten und ab dafür ****

    Application.Echo False

    ' **** gegebenenfalls Formular öffnen und Fokus setzen ****

    If gJump.sHerkunftsFormular <> gJump.sZielFormular Then
       DoCmd OpenForm gJump.sZielFormular, A_NORMAL
    End If

    CZielfeld.SetFocus

    ' **** Neuanlage oder nur Sprung ? ****

    If sAction = "NewComboBoxValue" Then
       DoCmd GoToRecord , , A_NEWREC
       CZielfeld = gJump.vZielWert
    Else
       DoCmd FindRecord gJump.vZielWert
    End If

    DoCmd ShowToolbar "Zurück", A_TOOLBAR_YES

exit_JumpTo:

    Application.Echo True
    DoCmd Hourglass False
    Exit Sub


err_JumpTo:

    If Err = 2110 And sAction = "NewComboBoxValue" Or sAction = "Go" Then
       On Error GoTo 0
       Resume Next
    Else
       Fehler "JumpTo"
       Resume exit_JumpTo
    End If

End Sub


Function JumpBack ()

    On Error GoTo err_JumpBack

    Dim FZ As Form

    DoCmd ShowToolbar "Zurück", A_TOOLBAR_NO

    If gJump.sAction = "" Then
       Exit Function
    End If

    ' **** Werteübergabe an globale Datentyp-Variable gJump ****

    gJump.sAction = ""

    ' Interessanterweise kann der bei Screen.ActiveControl auf-
    ' tretende Fehler, wenn das Herkunftsformular geschlossen
    ' wurde, durch einfaches Übergehen ignoriert werden.
    ' Der ursprüngliche gJump.sZielwert wird dann auf keinen Fall
    ' geändert und es erfolgt dann eben auch keine Wertzuweisung.

    On Error Resume Next
    gJump.vZielWert = Screen.ActiveControl
    On Error GoTo err_JumpBack

    ' **** Darstellung abschalten und ab dafür ****

    Application.Echo False

    ' **** gegebenenfalls anderes Formular schließen ****

    If gJump.sHerkunftsFormular <> gJump.sZielFormular Then
       DoCmd Close A_FORM, gJump.sZielFormular
    End If

    ' **** Formular evtl. öffnen und Fokus setzen ****

    If IsFormOpen(gJump.sHerkunftsFormular) = False Then
       DoCmd OpenForm gJump.sHerkunftsFormular
    End If

    ' **** ursprüngliche Ansicht wiederherstellen ****

    If Forms(gJump.sHerkunftsFormular).CurrentView <> gJump.iCurrentView Then
       If Forms(gJump.sHerkunftsFormular).CurrentView = 1 Then
          DoCmd RunMacro "Menübefehle.Ansicht_Datenblatt"
       Else
          DoCmd RunMacro "Menübefehle.Ansicht_Formular"
       End If
    End If

    ' **** Herkunftsdatensatz einstellen ****

     Forms(gJump.sHerkunftsFormular)(gJump.sIdentFeld).SetFocus
     DoCmd FindRecord gJump.vIdentWert

    ' **** evtl. Zusatzformular einblenden und Fokus setzen ****

    If gJump.sHerkunftsFormular = "Adressen" Then
       If gJump.sZusatzdaten <> "" Then
          SendKeys "%z", True
          Set FZ = Forms!Adressen!UF_Zusatzdaten.Form
          FZ(gJump.sZusatzdatenFeld).SetFocus
          If FZ(gJump.sHerkunftsFeld) <> gJump.vZielWert Then
             FZ(gJump.sHerkunftsFeld) = gJump.vZielWert
          End If
          gJump.sZusatzdaten = ""
       End If
    End If


exit_JumpBack:

    Application.Echo True
    DoCmd Hourglass False
    Exit Function


err_JumpBack:

    Fehler "JumpBack"
    Exit Function

End Function

Beim Steuerelement (meistens wohl eine ComboBox) passiert folgendes:

In NotInList:

    Beep

    If MsgBox("Wollen Sie '" & NewData & "' als neuen Adressen-Datensatz anlegen ?", 36, "Neueingabe") = 6 Then
       Response = DATA_ERRCONTINUE
       DoCmd RunMacro "Menübefehle.RückgängigFeld"
       JumpTo "NewComboBoxValue", "Adressen", "Suchname", NewData, "Suchname", Me!Suchname
    End If

In DblClick:

   JumpTo "Go", "Adressen", "Suchname", Me!Feld22, "Suchname", Me!Suchname

In KeyDown das bewährte

    If KeyCode = 32 And Shift = 2 Then
       KeyCode = 0
       Feld22_DblClick (0)
    End If

und in der Statuszeile etwas a'la lala: öffnet Stammdaten

Datensicherung Quelle: dmt Datum: 02.2005

Mittels einer Access-Anwendung an anstehende Datensicherungen zu erinnern sowie diese auch anzustoßen, hat sich bereits mehrfach bewährt.

In strobel.mdb (Access 2.0) wird eine Novell-Arcserve-Backup-Client-Anwendung geöffnet und per SendKeys ferngesteuert.

In bea.mdb wird ein Winzip-Kommandozeilen-Utility auf das Verzeichnis "c:\eigene dateien" losgelassen, um eine Datums-benannte Zip-Datei anzulegen.

Der Code in bea.mdb sieht so aus (bitte auch die neuere Version aus dmt.mdb weiter unten beachten):

Function Datensicherung()

    On Error GoTo err_Datensicherung

    Dim v As Variant, NameDatum As String

    ' Hinterlegte Kommando-Angaben aus der Tabelle holen
    v = Get_BesitzerWert("Winzip_Kommando", "Vorgaben")
    ' Datum umbauen: JahrMonatTag
    NameDatum = Year(Date) & Format(Month(Date), "00") & Format(Day(Date),"00")
    ' XYZ in Kommando-Angabe ersetzen durch das umgebaute Datum
    v = ReplaceInString(v, "XYZ", NameDatum)
    ' Benutzer fragen und evtl. abrechen
    Beep
    If MsgBox("Wollen Sie die aktuelle Datensicherungs-Zipdatei '" & NameDatum & ".zip' jetzt anlegen ?", vbQuestion + vbOKCancel, "Datensicherung") = vbCancel Then Exit Function
    ' Betriebssystem aufrufen und Kommando absetzen
    v = Shell(v, vbMaximizedFocus)
    ' Pause, um abzuwarten, bis die DOS-Box sich vollständig aufgebaut hat.
    Pause 2
    ' Tastendruck abschicken, um bei Lizenzmeldung weiterzumachen
    SendKeys "{ENTER}", True

exit_Datensicherung:

    Application.Quit acQuitPrompt
    Exit Function


err_Datensicherung:

    Fehler "Datensicherung"
    Resume exit_Datensicherung

End Function

Winzip-Kommando:

c:\tools\winzip\wzzip.exe -P -r -whs c:\save\XYZ.zip @c:\save\savelist.txt

* * * *

Und so geht das in der dmt.mdb (Access 2.0, 16Bit):

Private Sub Datensicherung ()

    On Error GoTo err_Datensicherung

    Dim v As Variant
    Dim sCdDrive As String, NameDatum As String, BackupDir As String, TempDir As String, sModus As String
    Dim ZipCommand As String, ZipDir As String, ZipFile As String, SaveList As String, CR As String, sTab As String

    Const CD_DRIVE_NAME1 = "HL-DT-ST DVDRAM GSA-4082B"
    Const CD_DRIVE_NAME2 = "HP CD-Writer+ 8100"
    Const REL_PATH_TO_ZIP_DIR = "\tools\packer\zip32"
    Const SCRIPT_SUB_DIR = "script"
    Const ZIP_DRIVE = "G:"

    ' **** Modus checken ****

    If InStr(Me!ExterneDateien, "manuell") > 0 Or InStr(Me!ExterneDateien, "große") > 0 Then
       sModus = "vollständigen"
       ZipCommand = "save_nt.bat"
    Else
       sModus = "kleinen"
       ZipCommand = "save_nt2.bat"
    End If

    ' **** Benutzer fragen ****

    Beep

    sTab = Chr$(9)
    CR = Chr$(13) & Chr$(10)

    v = "Schließen Sie vor dem Start der " & sModus & " Datensicherung alle anderen Anwendungen "
    v = v & "und legen Sie eine geeignete CD in das CD-Brenner-Laufwerk ein." & CR & CR
    v = v & "Wollen Sie das schnellere der verfügbaren Brenner-Laufwerke benutzen ?" & CR & CR
    v = v & "Ja" & sTab & sTab & CD_DRIVE_NAME1 & ": 24-fach" & CR
    v = v & "Nein" & sTab & sTab & CD_DRIVE_NAME2 & ": 4-fach" & CR
    v = v & "Abbrechen" & sTab & "bricht den Vorgang ab"

    v = MsgBox(v, 67, "Datensicherung")

    Select Case v
        Case 6:     sCdDrive = Chr$(34) & CD_DRIVE_NAME1 & Chr$(34)
        Case 7:     sCdDrive = Chr$(34) & CD_DRIVE_NAME2 & Chr$(34)
        Case Else:  Exit Sub
    End Select

    ' **** Betriebssystem abfragen und ab geht's ****

    If API_Is_WindowsNT_Running() = False Then
       Beep
       MsgBox "Der Betrieb unter Nicht-NT wurde noch nicht getestet !", 64, "Datensicherung"
       Exit Sub
    End If

    If CheckRohling(sCdDrive) = False Then Exit Sub

    ' Datum umbauen: JahrMonatTag
    NameDatum = Year(Date) & Format(Month(Date), "00") & Format(Day(Date), "00")
    TempDir = NameDatum & ".tmp"

    ' Um etwaigen Beschränkungen der Länge von Kommandozeilen-Befehlen zu entgehen, werden
    ' auf den jeweils verschiedenen Laufwerken die aktiven Arbeitsverzeichnisse eingestellt.

    BackupDir = GetDesktopDir()
    v = ForceDir(BackupDir)                 ' jeweiliger Desktop als aktives Laufwerk / Verzeichnis
    MkDir TempDir                           ' Temp-Verzeichnis anlegen
    ChDir TempDir                           ' und zum aktiven machen
    BackupDir = BackupDir & "\" & TempDir   ' und dessen Laufwerksbuchstaben als Batch-Parameter übernehmen

    ZipDir = ZIP_DRIVE & REL_PATH_TO_ZIP_DIR & "\" & SCRIPT_SUB_DIR

    v = ForceDir(ZipDir)

    ' **** Backup-Verzeichnis zur Identifikation nach erneutem Programmstart hinterlegen ****

    DoCmd SetWarnings False
    DoCmd RunSQL ("UPDATE vorgaben SET last_backup_dir = '" & BackupDir & "'")
    DoCmd SetWarnings True

    ' **** Zip-Batch aufrufen ****

    ZipCommand = ZipDir & "\" & ZipCommand & " " & BackupDir & " " & SCRIPT_SUB_DIR & " " & NameDatum & ".zip" & " " & sCdDrive

    v = Shell(ZipCommand, 3)

    Application.Quit


exit_Datensicherung:

    Exit Sub


err_Datensicherung:

    If Err = 75 Then
       Resume Next
    Else
       Fehler "Datensicherung"
       Resume exit_Datensicherung
    End If

End Sub

Dahinter stecken noch ein paar Kleinigkeiten:

Die Datensicherung wurde um eine Möglichkeit erweitert, zwischen verschiedenen Brennern auswählen zu können.

CheckRohling() checkt entsprechend dieser Auswahl einen CD-Rohling im gewählten Brenner-Laufwerk.

Für die CD-bezogenen Funktionen wird im vorliegenden Falle eine per Kommandozeile steuerbare Brennersoftware (Nero 6) benutzt.

Entsprechende Aufrufe erfolgen durch verschiedene, weiter unten gelistete DOS-Batchdateien.

Private Function CheckRohling (CdDrive As String) As Integer

    On Error GoTo err_CheckRohling

    Dim FF As Integer, iPos1 As Integer, iPos2 As Integer, iFreeMB As Long, LastBackupSize As Integer
    Dim v As Variant
    Dim s As String, sWarnung As String, sCdType As String, sCdProtected As String
    Dim CR As String * 2, sTab As String * 1, sFreeMB As String, sBlocksFree As String
    Dim BurnToolDrive As String * 1, CheckCommand As String

    Const CHECKBAT = "info.bat"
    Const TEMPFILE = "~info.txt"
    Const PATH_TO_BURN_TOOL = "tools\cd"

    Const CDTYPE = "CD-R"
    Const CDPROTECTED = "not writable"
    Const BLOCKSFREE = " blocks free"
    Const BYTEFACTOR = 2048

    BurnToolDrive = "m"
    sTab = Chr$(9)
    CR = Chr$(13) & Chr$(10)

    ' **** CD-Medium-Informationen checken ****

    FF = FreeFile

    v = ForceDir(BurnToolDrive & ":\" & PATH_TO_BURN_TOOL)

    CheckCommand = CHECKBAT & " " & CdDrive & " " & TEMPFILE

    v = Shell(CheckCommand, 1)

    WaitForActiveTask

    Open TEMPFILE For Input As #FF

    Line Input #FF, s

    Close #FF

    Kill TEMPFILE

    If InStr(s, "error") > 0 Then
       Beep
       If MsgBox("Die CD konnte nicht ausgelesen werden !" & CR & CR & "Evtl. kann die CD dennoch beschrieben werden (durch manuelle Bedienung einer Brenner-Software)." & CR & CR & "Soll die Datensicherung dennoch erstellt werden ?", 36, "CheckRohling") = 6 Then
          CheckRohling = True
       End If
       Exit Function
    End If

    iPos1 = InStr(s, ",")
    sCdType = Mid$(s, 1, iPos1 - 1)
    If sCdType <> CDTYPE Then
       sWarnung = "Ungültiger Medientyp:" & sTab & sTab & "'" & sCdType & "' anstelle von '" & CDTYPE & "'"
    End If

    iPos2 = InStr(iPos1 + 1, s, ",")
    sCdProtected = Mid$(s, iPos1 + 2, iPos2 - iPos1 - 2)
    If sCdProtected = CDPROTECTED Then
       If sWarnung <> "" Then sWarnung = sWarnung & CR
       sWarnung = sWarnung & "Die CD ist nicht beschreibbar:" & sTab & "'" & sCdProtected & "'"
    End If

    sBlocksFree = Mid$(s, iPos2 + 2)
    iFreeMB = (Val(sBlocksFree) * BYTEFACTOR) / 1024
    iFreeMB = iFreeMB / 1024
    sFreeMB = "Freier Platz auf der CD:" & sTab & sTab & iFreeMB & " MB"

    If sWarnung <> "" Then
       Beep
       MsgBox "Die CD ist unbrauchbar !" & CR & CR & sWarnung & CR & sFreeMB, , "CheckRohling"
       Exit Function
    End If

    ' **** Größe der letzten Backup-Datei checken ****

    If InStr(Me!ExterneDateien, "manuell") Or InStr(Me!ExterneDateien, "groß") Then
       LastBackupSize = DLookup("last_backup_size", "vorgaben")
    Else
       LastBackupSize = DLookup("last_small_backup_size", "vorgaben")
    End If

    LastBackupSize = LastBackupSize + (LastBackupSize / 10) ' zum Abschätzen um 10% erhöhen

    Beep

    If LastBackupSize > iFreeMB Then
       If MsgBox("Die CD verfügt wahrscheinlich nicht über den benötigten Speicherplatz !" & CR & CR & sFreeMB & CR & "Grob geschätzter Platzbedarf:" & sTab & LastBackupSize & " MB" & CR & CR & "Es ist wahrscheinlich ratsam, die CD zur besseren Lesbarkeit mittels einer geeigneten Brennsoftware zu 'fixieren'." & CR & CR & "Soll der Brennvorgang trotzdem gestartet werden ?", 260, "CheckRohling") = 6 Then
          CheckRohling = True
       End If
    Else
       If MsgBox("Der verfügbare Platz auf der CD sollte ausreichen." & CR & CR & sFreeMB & CR & "Grob geschätzter Platzbedarf:" & sTab & LastBackupSize & " MB" & CR & CR & "Soll der Brennvorgang jetzt gestartet werden ?", 4, "CheckRohling") = 6 Then
          CheckRohling = True
       End If
    End If

    Exit Function


err_CheckRohling:

    Fehler "CheckRohling"
    Exit Function

End Function

**** Und hier noch ein paar der beteiligten Batchdateien: ****

Die info.bat, die als Parameter die Laufwerkskennung sowie den Namen einer temporären Ergebnisdatei entgegennimmt.
Die Ausgabe des CD-Checks erfolgt dann in eben dieser Datei.
Die info.bat habe ich in dem Verzeichnis abgelegt, in dem die Brenner-Software liegt.

@echo off
rem **** Die Ausgabe dieser Datei wird extern ausgewertet und sollte zumindest am Anfang nicht ver„ndert werden ****
rem Parameter:
rem %1: Laufwerksbuchstabe
rem %2: Ausgabe-Datei
echo.
echo die CD wird berprft ...
echo.
echo Laufwerks-Kennung: %1
echo.
nerocmd.exe --cdinfo --drivename %1 > %2
echo.

Unter dem Verzeichnis meiner Winzip-Installation liegt ein script-Verzeichnis, in dem folgende Dateien liegen:

dont_nt.txt:

; *** Diese Dateien nicht sichern ****

I:\_burn\*.*
I:\_temp\*.*
I:\websites\php\phpmyadmin\*.*

list_nt.txt:

; **** Liste der durch winzip zu sichernden Dateien ****

; e:\*.mdb	-> wird in den Batches extra verarbeitet.
i:\*.*

list_nt1.txt:

; **** Konfigurationsdateien Not-NT ****

h:\winnt\system32\config\*.*
h:\winnt\profiles\administrator\ntuser.dat

sowie die eigentlichen Batches zur Ablaufsteuerung:

Interessant ist hier der Aufruf eines NT4-bezogenen Microsoft-Tools zur Sicherung der NT4-Registry-Dateien.
Das Programm rdisk.exe wird mit dem Parameter /s aufgerufen.
Nur so werden auch die SAM und SECURITY-Dateien gesichert.

save_nt.bat:

@echo off
rem
rem **** Um mehrere Sicherungstasks anstoáen zu k”nnen, wird das in einer DOS-Batch erledigt ****
rem
rem **** Parameter ****
rem %1: Vollst„ndiger Pfad zu dem Verzeichnis, in dem das Zip-Backup erstellt wird.
rem %2: Unterverzeichnis, in dem diese Scripte liegen, z.B. "script".
rem %3: Name der Tages-aktuellen zip-Datei.
rem %4: Name des Brenner-Laufwerkes, da z.B. der DVD-Brenner nicht über seinen DOS-Laufwerksbuchstaben erkannt wird.
rem
rem **** Bedeutung der wichtigsten Parameter fr wzzip ****
rem -a+   fge Dateien hinzu und setze Archiv-Bit zurck
rem -b... Pfad fr einen alternativen Pfad fr die zip-temp-Datei
rem -ex   maximale Kompression
rem -P    speichert vollst„ndige Pfadnamen
rem -r    rekursives Abarbeiten von Unterverzeichnissen
rem -whs  auch versteckte und System-Dateien
rem
rem Wechsle in das zip-Programm-Verzeichnis
cd ..
echo.
echo                   **** DMT-Datensicherung, vollst„ndig ****
echo.
echo Sichern der aktuellen Konfiguration des NT-Servers (Benutzereingriff beachten)
echo.
rem GOTO BURN
pause
echo.
echo Die aktuelle Konfiguration wird gesichert ...
echo.
J:\WINNTSRV\system32\rdisk.exe /s
echo Best„tigen Sie den Fortgang der Sicherungs-Routine ...
echo.
pause
echo.
echo - sichere Konfiguration NT Server ...
echo.
wzzip.exe -a+ -b%1 -ex -P -whs %1\nt_serv.zip @%2\list_nt3.txt
echo.
echo - sichere Konfiguration NT Not ...
echo.
wzzip.exe -a+ -b%1 -ex -P -whs %1\nt_not.zip @%2\list_nt1.txt
echo.
echo - sichere Konfiguration NT Brenner ...
echo.
wzzip.exe -a+ -b%1 -ex -P -whs %1\nt_burn.zip @%2\list_nt2.txt
echo.
echo - sichere Stammverzeichnis des Bootlaufwerkes c:\ ...
echo.
wzzip.exe -a+ -b%1 -ex -P -whs %1\c_root.zip c:\*.*
echo.
echo - sichere ge„nderte mdb-Dateien auf e:\ ...
echo.
wzzip.exe -b%1 -ex -i -P -r -whs %1\e_mdb.zip e:\*.mdb
echo.
echo - sichere komplettes Windaten-Laufwerk ...
echo.
rem hier wird eine Ausschluá- und eine Einschluáliste sowie obendrein das Desktop-Temp-Verzeichnis angegeben.
wzzip.exe -a+ -b%1 -ex -P -r -whs %1\%3 -x@%2\dont_nt.txt @%2\list_nt.txt %1\*.*
echo.
:BURN
echo - Der Brenn-Vorgang wird gestartet ...
echo.
m:
cd \tools\cd\
call nerocmd.bat %4 %1\%3
echo.
:READY
echo šberprfen Sie, ob der Brennvorgang samt Verifizierung erfolgreich war.
echo.
pause
rem Die Anwendung wieder starten
start e:\access\msaccess.exe i:\daten\office4\dmt\dmt.mdb /ini e:\windows\msacc20.ini /cmd BackupIsReady

und save_nt2.bat:

@echo off
rem
rem **** Um mehrere Sicherungstasks anstoáen zu k”nnen, wird das in einer DOS-Batch erledigt ****
rem
rem **** Parameter ****
rem %1: Vollst„ndiger Pfad zu dem Verzeichnis, in dem das Zip-Backup erstellt wird.
rem %2: Unterverzeichnis, in dem diese Scripte liegen, z.B. "script".
rem %3: Name der Tages-aktuellen zip-Datei.
rem %4: Name des Brenner-Laufwerkes, da z.B. der DVD-Brenner nicht über seinen DOS-Laufwerksbuchstaben erkannt wird.
rem
rem **** Bedeutung der wichtigsten Parameter fr wzzip ****
rem -i   fge nur Dateien hinzu, deren Archiv-Bit inzwischen wieder gesetzt wurde und setze dieses zurck
rem -b... Pfad fr einen alternativen Pfad fr die zip-temp-Datei
rem -ex   maximale Kompression
rem -P    speichert vollst„ndige Pfadnamen
rem -r    rekursives Abarbeiten von Unterverzeichnissen
rem -whs  auch versteckte und System-Dateien
rem
rem Wechsle in das zip-Programm-Verzeichnis
cd ..
echo.
echo **** DMT-Datensicherung, ge„nderte Dateien auf 'bigshit' und 'windaten' ****
echo.
pause
echo.
echo - sichere ge„nderte mdb-Dateien auf e:\ ...
echo.
wzzip.exe -a+ -b%1 -ex -i -P -r -whs %1\e_mdb.zip e:\*.mdb
echo.
echo - sichere ge„nderte Daten auf dem Windaten-Laufwerk ...
echo.
rem hier wird eine Ausschluá- und eine Einschluáliste sowie obendrein das Desktop-Temp-Verzeichnis angegeben.
wzzip.exe -b%1 -ex -i -P -r -whs %1\%3 -x@%2\dont_nt.txt @%2\list_nt.txt %1\*.*
echo.
:BURN
echo - Der Brenn-Vorgang wird gestartet ...
echo.
m:
cd \tools\cd\
call nerocmd.bat %4 %1\%3
echo.
:READY
echo šberprfen Sie, ob der Brennvorgang samt Verifizierung erfolgreich war.
echo.
pause
rem Die Anwendung wieder starten
start e:\access\msaccess.exe i:\daten\office4\dmt\dmt.mdb /ini e:\windows\msacc20.ini /cmd BackupIsReady2

Dokumentenverwaltung Quelle: dmt Datum: 03.2004

DOKUMENTENVERWALTUNG:

einfach, aber effektiv, sogar mit automatischem Auslesen der win.ini-Extensions-Einträge. Das möchte ich aber nicht unter Win9x+ probieren. Egal. s. bestatt.mdb

Download begleiten Quelle: dmt Datum: 06.2004

Im konkreten Beispiel kann in einer Access97-Anwendung der download einer Antiviren-Definitionsdatei gestartet und die danach nötigen, manuellen Schritte (zum Auspacken und implementieren) erledigt werden:

Eine Access2.0-Version findet sich in dmt.mdb.

Option Compare Database
Option Explicit

Const MYCAPTION = "Antiviren-Download"
Const DOWNLOAD_SITE = "http://download.mcafee.com/updates/4xa.asp?as=false&ref=5"
Const MYDESKTOPDIR = "c:\windows\desktop"
Const ANTIVIR_CHECKFILE = "scan.dat"

Dim Antivir_Dir As String, Antivir_File As String, Antivir_OldDate As Variant


Private Sub Form_Open(Cancel As Integer)

    On Error GoTo err_Form_Open_Antivir

    Dim bDauer As Byte

    Cancel = Not Set_Antivir_Data(Antivir_File, Antivir_Dir)

    Antivir_OldDate = FileDateTime(Antivir_File)

    ' Evtl. wird das Überprüfen des Alters der Antiviren-Prüfdaten angefordert

    If Not IsNull(Me.OpenArgs) Then
       If Me.OpenArgs = "check" Then
          bDauer = Now - FileDateTime(Antivir_File) - 1
          If bDauer > DLookup("Antiviren_Ablaufdauer", "Vorgaben") Then
             Beep
             MsgBox "Die vorhandenen Viren-Prüfdaten vom " & Format$(FileDateTime(Antivir_File), "dd.mm.yyyy") & " sind " & bDauer & " Tage alt." & vbCrLf & vbCrLf & "Starten Sie die Aktualisierung der Antiviren-Prüfdaten !",  vbExclamation, MYCAPTION
          Else
             Cancel = True
          End If
       End If
    End If

    Exit Sub


err_Form_Open_Antivir:


    If Err = 68 Then
       Exit Sub
    Else
       Fehler "Form_Open_Antivir"
    End If

    Exit Sub

End Sub


Private Sub pbStart_Click()

    On Error GoTo err_pbStart

    Dim v As Variant, sDownloadFile As String, s As String, sTempDir As
String

    Beep
    If MsgBox("Stellen Sie sicher, daß eine online-Verbindung besteht, indem Sie sich in das Internet einwählen." & vbCrLf & vbCrLf & "Schließen Sie danach das Browser-Fenster und fahren mit Punkt 2. fort." & vbCrLf & vbCrLf & "Wollen Sie die online-Verbindung jetzt aufbauen ?", vbQuestion + vbOKCancel, MYCAPTION) = vbCancel Then GoSub exit_pbStart

    v = Shell("c:\programme\internet explorer\iexplore.exe", vbNormalFocus)

    If MsgBox("Rufen Sie die Download-Webseite auf und klicken Sie im unteren Bereich der Seite auf die Download-Schaltfläche." & vbCrLf & vbCrLf & "Speichern Sie die angebotene Datei in dem vorgeschlagen Desktop-Verzeichnis ab." & vbCrLf & vbCrLf & "Warten Sie, bis die Daten vollständig übertragen wurden und schließen Sie danach das Browser-Fenster. Die online-Verbindung kann danach beendet werden." & vbCrLf & vbCrLf & "Wollen Sie die Download-Seite jetzt aufrufen ?", vbQuestion + vbOKCancel, MYCAPTION) = vbCancel Then GoSub exit_pbStart

    v = Shell("c:\programme\internet explorer\iexplore.exe" & " " & DOWNLOAD_SITE, vbNormalFocus)

    If MsgBox("Bestätigen Sie den erfolgreichen Download der Antiviren-Prüfdatei.", vbExclamation + vbOKCancel, MYCAPTION) = vbCancel
Then GoSub exit_pbStart

    sDownloadFile = Dir(MYDESKTOPDIR & "\*dat.exe")

    If sDownloadFile = "" Then
       MsgBox "Im Desktop-Verzeichnis liegt keine Antiviren-Datei !", vbCritical, MYCAPTION
       GoSub exit_pbStart
    End If

    sTempDir = MYDESKTOPDIR & "\temp"

    MkDir sTempDir
    FileCopy MYDESKTOPDIR & "\" & sDownloadFile, MYDESKTOPDIR & "\temp\" & sDownloadFile
    Meldung "Die Antiviren-Daten werden ausgepackt ..."
    v = Shell(sTempDir & "\" & sDownloadFile & " /E", vbHide)
    Meldung "Die Antiviren-Daten werden kopiert ..."

    ' Die Dateien müssen innerhalb von Access einzeln angefasst werden
    s = Dir(sTempDir)
    Do While s <> ""
        ' Aktuelles und übergeordnetes Verzeichnis ignorieren.
        If s <> "." And s <> ".." And s <> sDownloadFile Then
           FileCopy sTempDir & "\" & s, Antivir_Dir & "\" & s
        End If
        s = Dir
    Loop

    Kill sTempDir & "\*.*"
    RmDir sTempDir

    ' Desktop-Datei löschen, wenn das Datum der Checkdatei nicht veraltet ist
    If (Now - FileDateTime(Antivir_File) - 1) > DLookup("Antiviren_Ablaufdauer", "Vorgaben") Then
       Beep
       MsgBox "Die Viren-Prüfdaten konnten nicht erneuert werden !", vbCritical, MYCAPTION
    Else
       Kill MYDESKTOPDIR & "\" & sDownloadFile
       MsgBox "Die Aktualisierung der Viren-Prüfdaten war erfolgreich !", vbInformation, MYCAPTION
       DoCmd.Close acForm, Me.Name
    End If


exit_pbStart:

    Meldung ""
    Exit Sub


err_pbStart:

    Fehler "pbStart"
    Resume exit_pbStart

End Sub

Fehler Quelle: dmt Datum: 01.2005

FEHLER: Fehlerbehandlung / Fehlernummern

Eine Standard-Fehlerbehandlungsroutine a'la Schaltflächen-Assistent sieht so aus:

    Sub Sau_Click

        On Error Goto Err_Sau_Click

        ...
        ...

    Exit_Sau_Click:
        Exit Sub

    Err_Sau_Click:
        Msgbox Error$
        Resume Exit_Sau_Click

    End Sub

Wenn für ein Programm selbstdefinierte Fehlernummern vergeben werden sollen, so ist zu beachten, daß in Access bis jetzt die Nummern von 1 bis ca. 8.000 bereits vergeben sind und daß zukunftige Access-Versionen an diese Nummern anschließen werden. Um sicher zu gehen, sollten eigene Fehlernummern aus dem Zahlenbereich kleiner als 32.767 abwärts vergeben werden.

* * * *

FEHLERMELDUNG:

Bewährt ist die einheitliche Standardfehlermeldung über folgende Routine:

Sub Fehler (Titel As String)

    Dim CR As String, F As String

    Beep

    CR = Chr$(13) + Chr$(10)

    F = "Fehler: " + Error$ + CR + CR + "Code: " & Err

    MsgBox F, 16, Titel

End Sub

Im neueren Access97-Stil sieht das dann so aus:

Sub Fehler(s As String)

    Beep
    MsgBox "Fehler Nr. " & Err & vbCrLf & vbCrLf & Error$, vbCritical, s

End Sub

Wird einfach mit 'Fehler "Modulname"' aufgerufen und erinnert sich sogar noch an
die Fehler-Werte. Allerdings darf die Fehlerprozedur selbst keinen Errorhandler besitzen, weil bei dessen Invokation die vorhandenen Fehlerinformationen zurückgesetzt werden.

Für idiotensichere Programmierung kann mit Blick auf die 'Fehler 88'-Technik in
Open Access auch ein vereinfachtes 'Weird "Variable " & Variable, SubName' in
einem Case else oder sonstwo herhalten.

Sub Weird (sText As String, sSub As String)

    Beep

    MsgBox sText, 16, "Ungültiger Zustand in " & sSub

End Sub

Fortschritts-Anzeige Quelle: dmt Datum: 05.2006

STATUSANZEIGER / FORTSCHRITTSBALKEN:

Sub StatusAnzeige (Titel As String, Wert As Integer, Gesamt As Integer, iAccess As Integer)

    ' **** ULTIMATIVES STATUS-TOOL ****

    Dim sF As String, ProzWert As Integer, i As Integer
    Dim C1 As Control, C2 As Control, C3 As Control, C4 As Control, C5 As Control

    sF = "Status_Anzeige"

    ' **** Plausibilitätsprüfung ****

    If Wert > Gesamt Or Wert < 0 Or Gesamt < 0 Then
       Beep
       MsgBox "Ungültige Werte-Kombination '" & Wert & "' und '" & Gesamt & "'.", 16, "Statusanzeige"
       Exit Sub
    End If

    ' **** Statusanzeige bei Bedarf öffnen oder schließen ****

    If Not ExistsForm(sF) Then
       DoCmd OpenForm sF, , , , , , "StandAlone"
    ElseIf Wert = 0 And Gesamt = 0 Then
       DoCmd Close A_FORM, sF
       Exit Sub
    End If

    ' **** Objektvariablen setzen ****

    Set C1 = Forms(sF)!Gruen
    Set C2 = Forms(sF)!Rot
    Set C3 = Forms(sF)!txt_Wert
    Set C4 = Forms(sF)!txt_Text
    Set C5 = Forms(sF)!txt_Prozent

    ' **** Zeiger bei Bedarf verstecken oder Wert berechnen ****

    If Wert = 0 Then
       ProzWert = 0
       C1.Visible = False
    Else
       ProzWert = Int(100 / (Gesamt / Wert))
       C1.Visible = True
    End If

    ' **** Erscheinungsbild Grün auf Rot oder Access 2.0 ****

    If iAccess = True Then
       C1.BackColor = 16711680
       C2.Visible = False
       If ProzWert > 49 Then
          C3.ForeColor = 16777215
          C4.ForeColor = 16777215
          C5.ForeColor = 16777215
       Else
          C3.ForeColor = 0
          C4.ForeColor = 0
          C5.ForeColor = 0
       End If
    Else
       C1.BackColor = 65280
       C2.Visible = True
       C3.ForeColor = 0
       C4.ForeColor = 0
       C5.ForeColor = 0
    End If

    ' **** Steuerelemente einstellen ****

    C1.Width = C2.Width * (ProzWert / 100)
    C3.Caption = ProzWert
    C4.Caption = Titel

End Sub

Folgende Routine demonstriert das Handling:

Sub Test_StatusAnzeige ()

    Dim i As Integer, Summe As Integer, AccessModus As Integer, s As String

    s = "Fortschritt"

    Summe = 100

Nochmal:

    For i = 0 To Summe
        DoEvents
        StatusAnzeige s, i, Summe, AccessModus
    Next i

    For i = Summe To 0 Step -1
        DoEvents
        StatusAnzeige s, i, Summe, AccessModus
    Next i

    If AccessModus = False Then
       AccessModus = True
    Else
       GoSub Exit_Test_Statusanzeige
    End If

    GoSub Nochmal

Exit_Test_Statusanzeige:

    StatusAnzeige "", 0, 0, 0

End Sub

Wenn die Status-Anzeige (Aktualisierung Fortschrittsbalken) nur ruckelig aktualisiert wird, hilft folgendes:

Forms!Pflege_Ausgabe.Repaint

In diesem Beispiel findet der Code witzigerweise in einem eigenen Modul statt, während das Repaint auf das Formular bezogen ist, in dem der Code lediglich angestoßen wurde. Das funktioniert aber trotzdem wunderbar und der Fortschrittsbalken läuft brav in einzelnen Prozent-Schritten hoch.

größter Wert, Tabellenfeld Quelle: dmt Datum: 03.2004

Wie lang ist der größte/längste Wert der angegebenen Felder / Tabelle ?

Private Function Biggest_Char (Tabelle As String, Feld As String) As Integer

    On Error GoTo err_Biggest_Char

    Dim DB As Database, RS As Recordset, i As Integer, iMax As Integer

    Set DB = DBEngine.Workspaces(0).Databases(0)
    Set RS = DB.OpenRecordset(Tabelle)

    Do While Not RS.EOF
       If Not IsNull(RS(Feld)) Then
          i = Len(RS(Feld))
          If i > iMax Then
             iMax = i
          End If
       End If
       RS.MoveNext
    Loop

    Biggest_Char = iMax

    Exit Function


err_Biggest_Char:

    Fehler "Biggest_Char"
    Exit Function

End Function

Hilfe, Info Quelle: dmt Datum: 03.2004

HILFE / INFO:

Ein eigenes Hilfesystem, daß vom Anwender selbst editiert werden kann, ist nach meiner Ansicht hip. Die Positionier-Merkgeschichten können in hp_vhp.mdb und auch in laserjob.mda bewundert werden.

Einen sehr einfachen Weg geht der Schnellschuß in bestatt.mdb, der (nur) für Formulare deren Namen ausliest und einen neuen Info-Datensatz anlegt bzw. den gewünschten darstellt.

In der ersten Fassung konnte das sogar steuerelement-spezifisch gemacht werden, aber das führt dann doch zu weit.

Die vereinfachte, formularbezogene Form ist komplett in bestatt.mdb zu finden.
Eine Positioniermerkung kann bei Bedarf leicht aus laserjob.mda übernommen werden.

Function Hilfe ()

    On Error GoTo err_Hilfe

    Dim v As Variant
    Dim sForm As String, sControl As String

    sForm = Screen.ActiveForm.Name
    sControl = Screen.ActiveControl.Name

    ' **** Hilfe-Datensatz schon vorhanden ? ****

    v = DLookup("Info", "Info", "Formular='" & sForm & "' AND Steuerelement='" & sControl & "'")

    If IsNull(v) Then
       Beep
       If MsgBox("Wollen Sie einen neuen Info-Datensatz für " & sForm & " - " & sControl & " anlegen ?", 33, "Neuer Info-Datensatz") = 1 Then
          DoCmd OpenForm "Info", , , , , , sForm & "|" & sControl
       End If
    Else
       DoCmd OpenForm "Info", , , "Formular='" & sForm & "' AND Steuerelement='" & sControl & "'"
    End If

    Exit Function


err_Hilfe:

    Fehler "Hilfe"
    Exit Function

End Function

Leerzeichen, löschen Quelle: dmt Datum: 03.2004

In Anlehnung an ClearStringFrom() werden hier alle Datensätze einer Tabelle durchlaufen, deren Feldinhalte des übergebenen Feldes von z.B. Leerzeichen befreit werden.

s.a. ReplaceInString()

Private Sub Delete_all_Blanks (Tabelle As String, Feld As String)

    On Error GoTo err_Delete_all_Blanks

    Dim DB As Database, RS As Recordset, i As Integer, iMax As Integer

    Set DB = DBEngine.Workspaces(0).Databases(0)
    Set RS = DB.OpenRecordset(Tabelle)

    Do While Not RS.EOF
       If Not IsNull(RS(Feld)) Then
          RS.Edit
          RS(Feld) = ClearStringFrom(RS(Feld), " ")
          RS.Update
       End If
       RS.MoveNext
    Loop

    Exit Sub


err_Delete_all_Blanks:

    Fehler "Delete_all_Blanks"
    Exit Sub

End Sub

Meldungsfenster Quelle: dmt Datum: 03.2004

Klassische Routine für 'bitte warten ...'-Meldungen:

Sub Meldung (sText As String)

    ' Gebundenes Meldungs-Fenster; mit gegebenem Text öffnen
    ' oder mit leerem Text schließen; auch Statuszeile.

    On Error Resume Next                         ' evtl. Status-Clear-Fehler

    Dim v As Variant

    If sText = "" Then
       DoCmd Close A_FORM, "Meldung"
       v = SysCmd(SYSCMD_CLEARSTATUS)
    Else
       If SysCmd(SYSCMD_GETOBJECTSTATE, A_FORM, "Meldung") = OBJSTATE_OPEN Then
          Forms!Meldung!txt.Caption = sText      ' Wenn geöffnet, tritt Form_Open
       Else                                      ' nicht ein.
          DoCmd OpenForm "Meldung", , , , , , sText
       End If
       v = SysCmd(SYSCMD_SETSTATUS, sText)
       Forms!Meldung.Repaint                     ' wegen zeitkrit.
    End If                                       ' Eventualitäten

End Sub

Eine erweiterte Variante kann sogar die Schriftgröße des Meldungstextes in
Abhängigkeit von der Anzahl der darzustellenden Zeichen verändern:

Meldung (sText As String)

    ' Gebundenes Meldungs-Fenster; mit gegebenem Text öffnen
    ' oder mit leerem Text schließen; auch Statuszeile.

    On Error Resume Next                         ' evtl. Status-Clear-Fehler

    Dim v As Variant

    If sText = "" Then
       DoCmd Close A_FORM, "Meldung"
       v = SysCmd(SYSCMD_CLEARSTATUS)
    Else
       If SysCmd(SYSCMD_GETOBJECTSTATE, A_FORM, "Meldung") = OBJSTATE_OPEN Then
          Forms!Meldung!txt.Caption = sText      ' Wenn geöffnet, tritt Form_Open
       Else                                      ' nicht ein.
          DoCmd OpenForm "Meldung", , , , , , sText
       End If
       v = SysCmd(SYSCMD_SETSTATUS, sText)
       If Len(Forms!Meldung!txt.Caption) > 28 Then
          Forms!Meldung!txt.Fontsize = 8
       Else
          Forms!Meldung!txt.Fontsize = 12
       End If
       Forms!Meldung.Repaint                     ' wegen zeitkrit.
    End If                                       ' Eventualitäten

End Sub

Menüaktionen Quelle: dmt Datum: 03.2004

Zuweilen praktisch ist auch die Code-mäßige Nachbildung von MENÜAKTIONEN bzw. MENÜOPTIONEN, die sich schon länger in einem eigenen Modul MENU_VER20 präsentieren (s.a. DataToClipboard):

Sub Copy2ClipBoard ()

    On Error GoTo err_Copy2ClipBoard

    DoCmd DoMenuItem A_FORMBAR, A_EDITMENU, A_COPY, , A_MENU_VER20

    Exit Sub


err_Copy2ClipBoard:

    Fehler "Copy2ClipBoard"
    Exit Sub

End Sub

Sub Datensatz_speichern ()

    DoCmd DoMenuItem A_FORMBAR, A_FILE, A_SAVERECORD, , A_MENU_VER20

End Sub

Sub PasteFromClipboard ()

    On Error GoTo err_PasteFromClipboard

    DoCmd DoMenuItem A_FORMBAR, A_EDITMENU, A_PASTE, , A_MENU_VER20

    Exit Sub


err_PasteFromClipboard:

    Fehler "PasteFromClipboard"
    Exit Sub

End Sub

Sub Rueckgaengig_Feld ()

    DoCmd DoMenuItem A_FORMBAR, A_EDIT, A_UNDOFIELD, , A_MENU_VER20

End Sub

* * * *

Wie übertrage ich z.B. WERTE von Basic-VARIABLEN in die Windows-ZWISCHENABLAGE ?

Sub DataToClipboard(cClip As Control, vDaten As Variant, cFocus As Control)

    On Error GoTo err_DataToClipboard

    ' Vorausgesetzt wird ein vorhandenes dummy-Steuerelement, das sichtbar gemacht und mit einem
    ' übergebenen Wert versehen wird. Danach wird dieser Wert in die Zwischenablage eingefügt,
    ' das Element wieder unsichtbar gemacht und ein anderes, gewünschtes Steuerelement fokussiert.

    cClip.Visible = True
    cClip = vDaten
    cClip.SetFocus
    DoCmd.RunCommand acCmdCopy
    ' Aufhebung der Abhängigkeit von einem evtl. nicht vorhandenen Makro
    'DoCmd.RunMacro "Menübefehle.Zwischenablage_einfügen"
    cFocus.SetFocus
    cClip.Visible = False

    Exit Sub


err_DataToClipboard:

    Fehler "DataToClipboard"
    Exit Sub

End Sub

Einlesen der Wert aller Text-orientierten Formular-Felder mit formatierter
Übergabe an die Zwischenablage (vorausgesetzt wird auch hier ein dummy-Feld):

Sub pbClipboard_Click ()

    On Error GoTo err_pbClipboard_Click

    Dim i As Integer, s As String, sTab As String, CR As String, C As Control

    sTab = Chr$(9)
    CR = Chr$(13) & Chr$(10)

    ' Daten relevanter Feldtypen, die nicht leer sind, einsammeln

    For i = 0 To Me.Count - 1
        Set C = Me(i)
        If Not IsNull(C) Then
           If TypeOf C Is CheckBox Then
              s = s & CR & C.Name & ":" & sTab & C.Value
           ElseIf TypeOf C Is ComboBox Then
              s = s & CR & C.Name & ":" & sTab & C.Value
           ElseIf TypeOf C Is ListBox Then
              s = s & CR & C.Name & ":" & sTab & C.Value
           ElseIf TypeOf C Is OptionButton Then
              s = s & CR & C.Name & ":" & sTab & C.Value
           ElseIf TypeOf C Is TextBox Then
              s = s & CR & C.Name & ":" & sTab & C.Value
           ElseIf TypeOf C Is ToggleButton Then
              s = s & CR & C.Name & ":" & sTab & C.Value
           End If
        End If
    Next i

    ' an dummy-Feld zuweisen und an Zwischenablage übergeben

    If s <> "" Then
       Set C = Me!dummy_clipboard
       C.Visible = True
       C = s & CR
       C.SetFocus
       DoCmd DoMenuItem A_FORMBAR, A_EDITMENU, A_COPY
       Me!pbClipboard.SetFocus
       C = Null
       C.Visible = False
       Beep
    End If


exit_pbClipboard_Click:

    Set C = Nothing
    Exit Sub


err_pbClipboard_Click:

    If Err <> 2427 Then
       Fehler "pbClipboard_Click"
       Resume exit_pbClipboard_Click
    Else
       Resume Next
    End If

End Sub

MODUL: Arrays Quelle: dmt Datum: 06.2004

ARRAYS:

Hinweis: Das Modul läßt sich nicht 1 zu 1 in Access 2.0 einsetzen, da es z.B. bei der Übergabe von Arrays als Parameter-Variable in der aufgerufenen Prozedur (z.B. CountArrayValues()) zu Kompilierungsfehlern kommt.

Erst die Entfernung des Parameters und Ansprechen eines als mind. Modulweit deklarierten Arrays macht die Routine wieder benutzbar.

Option Compare Database
Option Explicit


Function CountArrayValues(vArray As Variant) As Variant

    On Error GoTo err_CountArrayValues

    CountArrayValues = UBound(vArray) - LBound(vArray) + 1

    Exit Function


err_CountArrayValues:

    If Err = 9 Then
       CountArrayValues = 0
    Else
       Fehler "CountArrayValues"
    End If

    Exit Function

End Function


Function CountInArray(v As Variant, sPattern As String, Optional iWo As Integer) As Integer

    On Error GoTo err_CountInArray

    Dim a As Integer, z As Integer, i As Integer, iAnz As Integer

    ' Der optionale Parameter iWo wurde eingeführt, um String-Vergleiche am Anfang, am Ende oder
    ' irgendwo mittendrin durchzuführen, um z.B. ".htm" nicht in die ".html"-Falle tappen zu lassen.

    ' iWo = 0 steht für irgendwo mittendrin, 1 für vorne und 2 für hinten.

    a = LBound(v)
    z = UBound(v)

    ' Um ständige if-Abfragen zu vermeiden, wird der Schleifen-Durchlauf redundant hinterlegt.

    If iWo = 0 Then
       For i = a To z
           If InStr(v(i), sPattern) > 0 Then
              iAnz = iAnz + 1
           End If
       Next i
    ElseIf iWo = 1 Then
       For i = a To z
           If Left$(v(i), Len(sPattern)) = sPattern Then
              iAnz = iAnz + 1
           End If
       Next i
    ElseIf iWo = 2 Then
       For i = a To z
           If Right$(v(i), Len(sPattern)) = sPattern Then
              iAnz = iAnz + 1
           End If
       Next i
    Else
       Beep
       MsgBox "Ungültiger Wert für Parameter iWo = " & iWo & " !", vbCritical, "Modul: Arrays - CountInArray"
    End If

    CountInArray = iAnz

    Exit Function


err_CountInArray:

    Fehler "CountInArray"
    Exit Function

End Function


Sub SortiereArray(vArray As Variant)

    On Error GoTo err_SortiereArray

    Dim a As Integer, z As Integer, i1 As Integer, i2 As Integer
    Dim Wert1 As String, Wert2 As String

    If IsEmpty(vArray) Then Exit Sub

    a = LBound(vArray)
    z = UBound(vArray)

    For i1 = a To z
        For i2 = i1 + 1 To z
            Wert1 = vArray(i1)
            Wert2 = vArray(i2)
            If Wert2 < Wert1 Then
                vArray(i1) = Wert2
                vArray(i2) = Wert1
            End If
        Next i2
    Next i1

    Exit Sub


err_SortiereArray:

    If Err <> 9 Then
       Fehler "SortiereArray"
    End If

    Exit Sub

End Sub

MODUL: Listenfelder Quelle: dmt Datum: 03.2004

LISTENFELDER:

Option Compare Database
Option Explicit


Function GetListFieldAsString(cListField As Control) As String

    On Error GoTo err_GetListFieldAsString

    Dim i As Integer, s As String

    For i = 0 To cListField.ListCount - 1
        s = s & cListField.ItemData(i) & " "
    Next i

    GetListFieldAsString = Trim$(s)

    Exit Function


err_GetListFieldAsString:

    Fehler "GetListFieldAsString"
    Exit Function

End Function


Function GetListFieldRowSourceFromArray(vArray As Variant) As String

    On Error GoTo err_GetListFieldRowSourceFromArray

    Dim s As String, a As Integer, z As Integer, i As Integer

    If IsEmpty(vArray) Then Exit Function

    a = LBound(vArray)
    z = UBound(vArray)

    For i = a To z
        s = s & vArray(i) & ";"
    Next i

    GetListFieldRowSourceFromArray = s

    Exit Function


err_GetListFieldRowSourceFromArray:

    If Err = 9 Then
       GetListFieldRowSourceFromArray = ""
    Else
       Fehler "GetListFieldRowSourceFromArray"
    End If

    Exit Function

End Function


Function HasListfieldSelections(cListField As Control) As Boolean

    On Error GoTo err_HasListfieldSelections

    If cListField.ItemsSelected.Count = 0 Then
       Beep
       MsgBox "In der Liste '" & cListField.Name & "' wurde kein Eintrag ausgewählt !", vbExclamation, "HasListfieldSelections"
    Else
       HasListfieldSelections = True
    End If

    Exit Function


err_HasListfieldSelections:

    Fehler "HasListfieldSelections"
    Exit Function

End Function


Function GetListFieldRowSourceWithAnzahlFromArray(vSubdaten As Variant, vTopdaten As Variant) As String

    On Error GoTo err_GetListFieldRowSourceWithAnzahlFromArray

    Dim s As String, a As Integer, z As Integer, i As Integer

    If IsEmpty(vSubdaten) Then Exit Function

    a = LBound(vSubdaten)
    z = UBound(vSubdaten)

    For i = a To z
        s = s & vSubdaten(i) & ";" & CountInArray(vTopdaten, "." & vSubdaten(i), 2) & ";"
    Next i

    GetListFieldRowSourceWithAnzahlFromArray = s

    Exit Function


err_GetListFieldRowSourceWithAnzahlFromArray:

    If Err = 9 Then
       GetListFieldRowSourceWithAnzahlFromArray = ""
    Else
       Fehler "GetListFieldRowSourceWithAnzahlFromArray"
    End If

    Exit Function

End Function


Function SelectListFieldElements(cListField As Control, bolAlle As Boolean)

    On Error GoTo err_SelectListFieldElements

    Dim i As Integer

    If cListField.ListCount = 0 Then
       Beep
       MsgBox "Die Liste der '" & cListField.Name & "' enthält keinen Eintrag !" & vbCrLf & vbCrLf & "Starten Sie die Ermittlung der Dateitypen in einem gewünschten Verzeichnis.", vbExclamation, "SelectListFieldElements"
       Exit Function
    End If

    For i = 0 To cListField.ListCount - 1
        cListField.Selected(i) = bolAlle
    Next i

    Exit Function


err_SelectListFieldElements:

    Fehler "SelectListFieldElements"
    Exit Function

End Function

MODUL: Verzeichnisse rekursiv Quelle: dmt Datum: 12.2004

VERZEICHNISSE REKURSIV DURCHSUCHEN ("Verzeichnisse_rekursiv_durchsuchen"):

Komplettes Modul (Access 97):

Option Compare Database
Option Explicit

Private Sub Beispiel_Aufruf()

    Dim i As Integer, a As Integer, z As Integer, v As Variant

    ' v nimmt als Array die rekursiv ermittelten Dateinamen auf
    ' gesucht wird im übergebenen Pfad
    ' Ein Substring wird als Namensteil zur Filterung benutzt.
    ' AllFiles bewirkt bei nein, daß nur tagesaktuelle Dateien ermittelt werden.

    Meldung "Die Verzeichnisinhalte werden durchsucht ..."
    CrawlDirs v, "C:\Eigene Dateien\homepage\websites\blummer", ".ht", Null
    Meldung ""

    If IsEmpty(v) Then
       Beep
       MsgBox "Es konnten keine Array-Daten ermittelt werden.", vbCritical, "pbReadData"
       'GoSub exit_pbReadData
    End If

    a = LBound(v)
    z = UBound(v)

    For i = a To z
      Debug.Print v(i)
    Next i

End Sub

Sub CrawlDir(vArray As Variant, Pfad As String, Pattern As String, Optional iWo As Integer)

    ' Beispiel-Aufruf:
    ' Dim v()
    ' CrawlDir v, "I:\websites\breitenbuecher\info\myway\javascript", "htm"

    ' Der optionale Parameter iWo wurde eingeführt, um String-Vergleiche am Anfang, am Ende oder
    ' irgendwo mittendrin durchzuführen, um z.B. ".htm" nicht in die ".html"-Falle tappen zu lassen.

    ' iWo = 0 steht für irgendwo mittendrin, 1 für vorne und 2 für hinten.

    On Error GoTo err_CrawlDir

    Dim i As Integer, sPfad As String, sName As String

    sPfad = Pfad & "\"
    sName = Dir(sPfad, vbDirectory)                 ' Ersten Eintrag abrufen

    Do While sName <> ""                            ' Schleife beginnen
        If sName <> "." And sName <> ".." Then      ' Aktuelles und übergeordnetes Verzeichnis ignorieren
           ' Mit bit-weisem Vergleich sicherstellen, daß sName eine Datei und kein Verzeichnis ist.
            If (GetAttr(sPfad & sName) And vbDirectory) <> vbDirectory Then
               If (Pattern = "" Or HasPattern(sName, Pattern, iWo) = True) Then  ' InStr(sName, Pattern) > 0) Then
                  ReDim Preserve vArray(i)
                  vArray(i) = Pfad & "\" & sName    ' komplett mit Pfad
                  i = i + 1
               End If
            End If
        End If
        sName = Dir                                 ' Nächsten Eintrag abrufen
    Loop

    SortiereArray vArray

    Exit Sub


err_CrawlDir:

    Fehler "CrawlDir"
    Exit Sub

End Sub

Sub CrawlDirs(vArray As Variant, Pfad As String, NamensTeil As String, vLastCheckDatum As Variant, Optional iNoSort As Boolean, Optional iWo As Integer, Optional DontReduce As Boolean)

   On Error GoTo err_CrawlDirs

   ' Der optionale Parameter iWo wurde eingeführt, um String-Vergleiche am Anfang, am Ende oder
   ' irgendwo mittendrin durchzuführen, um z.B. ".htm" nicht in die ".html"-Falle tappen zu lassen.

   ' iWo = 0 steht für irgendwo mittendrin, 1 für vorne und 2 für hinten.

'Dieser Source stammt von http://www.activevb.de und kann frei verwendet werden.
'Für eventuelle Schäden wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source !

'Autor: R. Mueller
'Email: r.mueller@sz-online.de

'Beitrag zum Thema Ordner und Laufwerke nach bestimmten oder allen Dateien rekursiv durchsuchen.
'Beide dargestellten Varianten benutzen keine API sondern die Function Dir$.

'1.Variante: Liste speichern in Datei
'2.Variante: Liste speichern Datenfeld

' Anmerkung: Die Ausgabe erfolgt zu Testzwecken sowohl im Debug-Fenster als auch und in der Datei "C:\Test.txt"

' Die vorliegende Version wurde angepaßt von Thomas Breitenbücher www.breitenbuecher.de

' Zusätzliche Parameter erlauben Vergleiche mit dem Dateidatum sowie Abschalten der Sortierung der Treffer

   Dim xpath$       'Pfad durchsuchen
   Dim xSF$         'gesuchte Files keine Platzhalter
   Dim xfn&
   Dim xdn$         'Dateiname zum Speichern der Liste
   Dim xArray$()
   Dim xln&         'Array index

   xpath$ = Pfad

   xSF$ = NamensTeil
   xSF$ = UCase(xSF$)

   Call xDirArray(xpath$, xArray$(), xln&, xSF$, vLastCheckDatum, iWo)

   If iNoSort = False Then
      Sortiere2DArrayDirsFiles vArray, xArray$(), "Verzeichnisse", "Dateinamen", DontReduce
   Else
      ReduziereArray vArray, xArray$()
   End If

   Exit Sub


err_CrawlDirs:

    Fehler "CrawlDirs"
    Exit Sub

End Sub

Sub CrawlDirsOnlyDirs(vArray As Variant, Pfad As String, NamensTeil As String, vLastCheckDatum As Variant, Optional iWo As Integer)

   On Error GoTo err_CrawlDirsOnlyDirs

'Dieser Source stammt von http://www.activevb.de und kann frei verwendet werden.
'Für eventuelle Schäden wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source !

'Autor: R. Mueller
'Email: r.mueller@sz-online.de

'Beitrag zum Thema Ordner und Laufwerke nach bestimmten oder allen Dateien rekursiv durchsuchen.
'Beide dargestellten Varianten benutzen keine API sondern die Function Dir$.

'1.Variante: Liste speichern in Datei
'2.Variante: Liste speichern Datenfeld

'Anmerkung: Die Ausgabe erfolgt zu Testzwecken sowohl im Debug-Fenster als auch und in der Datei "C:\Test.txt"

   Dim xpath$       'Pfad durchsuchen
   Dim xSF$         'gesuchte Files keine Platzhalter
   Dim xfn&
   Dim xdn$         'Dateiname zum Speichern der Liste
   ReDim xArray$(0) 'Datenfeld zum Speichern der Liste
   Dim xln&         'Array index
   Dim xi&

   'gesamtes Laufwerk durchsuchen
   'xpath$ = "D:"

   'Pfad durchsuchen z.B.
   xpath$ = Pfad

   'gesuchter Filename enthält folgenden String z.B.:
   'xSF$ = ".EXE" 'oder
   'xSF$ = ".v"   'oder
   'xSF$ = ".doc"

   xSF$ = NamensTeil
   xSF$ = UCase(xSF$)

'   '1.Variante: Liste speichern in Datei
'   xdn$ = "C:\Test.txt"  'Dateiname zum Speichern der Liste
'   xfn& = FreeFile
'   Open xdn$ For Output As xfn&
'     Call xDirFile(xpath$, xfn&, xSF$)
'   Close xfn&

   '2.Variante: Liste speichern Datenfeld
   Call xDirArrayOnlyDirs(xpath$, xArray$(), xln&, xSF$, vLastCheckDatum, iWo)

   'Ausgabe Array inhalt z.B.:
   'For xi& = 1 To UBound(xArray$)
   '  Debug.Print xArray$(xi&)
   'Next xi&

'   xMain = xArray$
'ReDim Preserve RekursiveTreffer$(xln&)


    SortiereArray xArray$()

    TransferArray xArray$(), vArray

    'vArray = xArray$()

    'xi& = xi&

    Exit Sub


err_CrawlDirsOnlyDirs:

    Fehler "CrawlDirsOnlyDirs"
    Exit Sub


End Sub

Private Sub xDirFile(xpath$, xfn&, xSF$, Optional iWo As Integer)

    Dim xa&
    Dim xDir$
    ReDim xt$(0)
    Dim xi&
    Dim xAc$

    'nur die nichtdokumentierte 63 liefert alle file auch Hidden- und System-Dateien
    xDir$ = Dir$(xpath$ & "\*.*", 63)
    xa& = 0

    If Not xDir$ = "" Then
       xt$(0) = xDir$
    End If

    Do While Not xDir$ = ""
       xDir$ = Dir$
       If Not xDir$ = "" And Not xDir$ = "." And Not xDir$ = ".." Then
          xa& = xa& + 1
          ReDim Preserve xt$(xa&)
          xt$(xa&) = xDir$
       End If
    Loop

    For xi& = 0 To xa&
      If xt$(xi&) = "" Then
        Exit For
      ElseIf Not xt$(xi&) = "." And Not xt$(xi&) = ".." Then
        If Not Dir$(xpath$ & "\" & xt$(xi&), 63) = "" Then              'Alle Files "\*.*" darf nicht verändert werden
          If Not GetAttr(xpath$ & "\" & xt$(xi&)) = vbDirectory Then    'vbDirectory =16
            If Len(xSF$) > 0 Then
              If HasPattern(UCase(xt$(xi&)), xSF$, iWo) = True Then     'InStr(1, UCase(xt$(xi&)), xSF$) > 0 Then
                xAc$ = xpath$ & "\" & xt$(xi&)
                Print #xfn&, xAc$
              End If
            End If
          End If
        End If
        Call xDirFile(xpath$ & "\" & xt$(xi&), xfn&, xSF$)
      End If
    Next xi&

End Sub

Private Sub xDirArray(xpath$, xArray$(), xln&, xSF$, vLastCheckDatum As Variant, Optional iWo As Integer)

   On Error GoTo err_xDirArray

   Dim bolInsert As Boolean
   Dim xa&
   Dim xDir$
   ReDim xt$(0)
   Dim xi&

   'Nur die nichtdokumentierte 63 liefert alle file auch Hidden- und System-Dateien

   If GetAttr(xpath$) = vbDirectory Then
      xDir$ = Dir$(xpath$ & "\*.*", 63)  '"\*.*" darf nicht verändert werden
   Else
      'xDir$ = xpath$
   End If

   xa& = 0

   If Not xDir$ = "" Then
     xt$(0) = xDir$
   End If

   Do While Not xDir$ = ""
     xDir$ = Dir$
     If Not xDir$ = "" And Not xDir$ = "." And Not xDir$ = ".." Then
       xa& = xa& + 1
       ReDim Preserve xt$(xa&)
       xt$(xa&) = xDir$
     End If
   Loop

   For xi& = 0 To xa&
     If xt$(xi&) = "" Then
       Exit For
     ElseIf Not xt$(xi&) = "." And Not xt$(xi&) = ".." Then
       If Not Dir$(xpath$ & "\" & xt$(xi&), 63) = "" Then
         If Not GetAttr(xpath$ & "\" & xt$(xi&)) = vbDirectory Then     'vbDirectory =16
           If Len(xSF$) > 0 Then
             If HasPattern(UCase(xt$(xi&)), xSF$, iWo) = True Then      'InStr(1, UCase(xt$(xi&)), xSF$) > 0 Then
               GoSub insert_xDirArray
             End If
           Else             ' kein SearchPattern
             GoSub insert_xDirArray
           End If
         End If
       End If
       Call xDirArray(xpath$ & "\" & xt$(xi&), xArray$(), xln&, xSF$, vLastCheckDatum)
     End If
   Next xi&

   Exit Sub


insert_xDirArray:

    bolInsert = False

    If Not IsNull(vLastCheckDatum) Then
       If IsDate(vLastCheckDatum) Then
          If CVDate(vLastCheckDatum) <= CVDate(FileDateTime(xpath$ & "\" & xt$(xi&))) Then
             bolInsert = True
          End If
       Else
          Beep
          MsgBox "ungültiges LastCheckDatum: " & vLastCheckDatum
       End If
    Else
       bolInsert = True
    End If

    If bolInsert = True Then
       ReDim Preserve xArray$(1, xln&)
       xArray$(0, xln&) = xpath$ & "\" & xt$(xi&)
       xArray$(1, xln&) = xpath$
       xln& = xln& + 1
    End If

    Return


err_xDirArray:

    Fehler "xDirArray: " & xpath$
    Exit Sub

End Sub

Private Sub xDirArrayOnlyDirs(xpath$, xArray$(), xln&, xSF$, vLastCheckDatum As Variant, Optional iWo As Integer)

   Dim xa&
   Dim xDir$
   ReDim xt$(0)
   Dim xi&

   'Nur die nichtdokumentierte 63 liefert alle file auch Hidden- und System-Dateien

   xDir$ = Dir$(xpath$ & "\*.*", 63)  '"\*.*" darf nicht verändert werden
   xa& = 0

   If Not xDir$ = "" Then
     xt$(0) = xDir$
   End If

   Do While Not xDir$ = ""
     xDir$ = Dir$
     If Not xDir$ = "" And Not xDir$ = "." And Not xDir$ = ".." Then
       xa& = xa& + 1
       ReDim Preserve xt$(xa&)
       xt$(xa&) = xDir$
     End If
   Loop

   For xi& = 0 To xa&
     If xt$(xi&) = "" Then
       Exit For
     ElseIf Not xt$(xi&) = "." And Not xt$(xi&) = ".." Then
       If Not Dir$(xpath$ & "\" & xt$(xi&), 63) = "" Then
         If GetAttr(xpath$ & "\" & xt$(xi&)) = vbDirectory Then    'vbDirectory =16
'           If Len(xSF$) > 0 Then
'             If InStr(1, UCase(xt$(xi&)), xSF$) > 0 Then
               xln& = xln& + 1
               If Not IsNull(vLastCheckDatum) Then
                  If IsDate(vLastCheckDatum) Then
                     If CVDate(vLastCheckDatum) - 1 <= CVDate(FileDateTime(xpath$ & "\" & xt$(xi&))) Then
                        ReDim Preserve xArray$(xln&)
                        xArray$(xln&) = xpath$ & "\" & xt$(xi&)
                     End If
                  Else
                     Beep
                     MsgBox "ungültiges LstCheckDatum: " & vLastCheckDatum
                  End If
               Else
                  ReDim Preserve xArray$(xln&)
                  xArray$(xln&) = xpath$ & "\" & xt$(xi&)
               End If
'             End If
'           End If
            Call xDirArrayOnlyDirs(xpath$ & "\" & xt$(xi&), xArray$(), xln&, xSF$, vLastCheckDatum)
         End If
       End If
     End If
   Next xi&

End Sub

Private Function HasPattern(v As Variant, vPattern As Variant, iWo As Integer) As Boolean

    On Error GoTo err_HasPattern

    If iWo = 0 Then
       HasPattern = InStr(v, vPattern) > 0
    ElseIf iWo = 1 Then
       HasPattern = Left$(v, Len(vPattern)) = vPattern
    ElseIf iWo = 2 Then
       HasPattern = Right$(v, Len(vPattern)) = vPattern
    End If

    Exit Function


err_HasPattern:

    Fehler "HasPattern"
    Exit Function

End Function

Sub Show_Files(Pfad As String, Suchmuster As String, Optional OutputFile As String, Optional PathNotToPrint As String, Optional UnixSlashes As Boolean)

    On Error GoTo err_Show_Files

    Dim i As Integer, a As Integer, z As Integer, FF As Integer, s As String, v As Variant

    ' Bei überlangen Inhalten kann die Dateiliste nicht im Info-Fenster bearbeitet werden.
    ' In diesem Falle kann die Ausgabe alternativ in eine Textdatei erfolgen.

    Meldung "Die Verzeichnisinhalte werden durchsucht ..."
    CrawlDirs v, Pfad, Suchmuster, Null
    Meldung ""

    If IsEmpty(v) Then
       Beep
       MsgBox "Es konnten keine Array-Daten ermittelt werden.", vbCritical, "Show_Files"
       Exit Sub
    End If

    Meldung "Lese Arraydaten aus ..."

    a = LBound(v)
    z = UBound(v)

    For i = a To z
      If PathNotToPrint <> "" Then v(i) = ReplaceInString(v(i), PathNotToPrint, "")
      If UnixSlashes = True Then v(i) = ReplaceInString(v(i), "\", "/")
      s = s & v(i) & vbCrLf
    Next i

    If Suchmuster = "" Then Suchmuster = "*.*"

    If OutputFile = "" Then
       ZeigeInhalte Suchmuster & "-Dateien im Verzeichnis " & Pfad, s, "", "", i
    Else
       FF = FreeFile
       Open OutputFile For Output As FF
            Print #FF, ""
            Print #FF, i & " " & Suchmuster & "-Dateien im Verzeichnis " & Pfad
            Print #FF, ""
            Print #FF, s
       Close #FF
    End If

    Beep
    Meldung ""

    Exit Sub


err_Show_Files:

    If FF > 0 Then
       Close #FF
       Meldung ""
    End If

    Fehler "Show_Files"
    Exit Sub

End Sub

Normalisierung Quelle: dmt Datum: 03.2004

NORMALISIERUNG / TOOLS:

Ein großes Wort gelassen niedergeschrieben.

Typischer Fall:

In den Literatur-dBase-Tabellen der SEL Alcatel-Stiftung wurden jahrelang Mehrfach-Nennungen von Personen, Körperschaften und Schlagworten in jeweils einem Feld vorgenommen. Als Trennzeichen wurden in wahlfreier Manier '*', ';'
oder ',' verwandt.

Ein von mir (von wem sonst ?) geschriebenes Tool durchläuft eine Datenquelle, zerlegt diese Strings in einzelne Begriffe und legt mit Nennung des Herkunfts-IDs einzelne Begriffsdatensätze an.

Function Extract_Strings_to_Table ()

Exit Function

 '   On Error GoTo err_Extract_Strings_to_Table

    ' **** durchläuft für jeden Quell-Datensatz alle Zeichen der ****
    ' **** der Schlagwort-Kette und legt einzelne Schlagwort-    ****
    ' **** Datensätze in einer Zuordnungstabelle an.             ****

    Dim i As Integer, iPos As Integer, iTrenn As Integer, iStart As Integer
    Dim v As Variant, s As String, sTrenn As String, sSchlagwort As String
    Dim DB As Database, RSQ As Recordset, RST As Recordset

    ' **** Variablen vereinbaren ****

    Set DB = DBEngine.Workspaces(0).Databases(0)

    Set RSQ = DB.OpenRecordset("Verlorene_Seelen_Q")    ', DB_OPEN_TABLE)
    Set RST = DB.OpenRecordset("Schlagwort_Zuordnungen", DB_OPEN_TABLE)

    ' **** sTrenn enthält Zeichen, die als Trennzeichen gewertet werden ****

    sTrenn = "*;,"

    ' **** Anzahl der Datensätze in Quelltabelle ermitteln ****

    RSQ.MoveLast
    v = SysCmd(SYSCMD_INITMETER, "öffne Datenquelle ...", RSQ.RecordCount)
    RSQ.MoveFirst

    ' **** Schleife durch alle Quelldaten ****

    Do While Not RSQ.EOF

       i = i + 1
       iStart = 1

       If IsNull(RSQ.Schlagwort) Then
          s = ""
       Else
          s = RSQ.Schlagwort
       End If

       ' **** String zeichenweise durchlaufen ****

       For iPos = 1 To Len(s)

           iTrenn = InStr(sTrenn, Mid$(s, iPos, 1))

           If iTrenn > 0 Then

              GoSub Set_Schlagwort

              iStart = iPos + 1

           End If

       Next iPos

       GoSub Set_Schlagwort     ' verbleibende Strings o. kein Trennzeichen

       RSQ.MoveNext

       v = SysCmd(SYSCMD_UPDATEMETER, i)

    Loop

    ' **** Zuordnungstabelle öffnen ****

    DoCmd OpenTable RST.Name


exit_Extract_Strings_to_Table:

    v = SysCmd(SYSCMD_CLEARSTATUS)
    Exit Function


Set_Schlagwort:

    If Len(s) = 0 Then Return

    sSchlagwort = Trim$(Mid$(s, iStart, iPos - iStart))

    If Len(sSchlagwort) > 0 Then

        RST.AddNew
        RST.Ident = RSQ.Ident
        RST.Schlagwort = sSchlagwort
        RST.Update

    End If

    Return


err_Extract_Strings_to_Table:

    Fehler "Extract_Strings_to_Table"
    GoSub exit_Extract_Strings_to_Table

End Function

Für den Fall, daß unerwarteterweise Fehler auftreten und ein teilweise erfolgreicher Export nicht gelöscht werden soll, kann mit Hilfe der folgenden Abfrage eine Überprüfung verwaister Datensätze vorgenommen werden:

Verlorene_Seelen_Q:

SELECT LITSTG.Schlagwort AS Schlagwort, Schlagwort_Zuordnungen.Schlagwort, LITSTG.IDENT
FROM LITSTG LEFT JOIN Schlagwort_Zuordnungen ON LITSTG.IDENT = Schlagwort_Zuordnungen.Ident
WHERE LITSTG.Schlagwort<>Null AND Schlagwort_Zuordnungen.Schlagwort=Null;

zeigt alle Datensätze der linken Seite 'LITSTG' (deswegen LEFT JOIN), die zwar ein Schlagwort enthalten, zu denen aber in der Tabelle Schlagwort_Zuordnungen keine Auflösungs-Datensätze bestehen.

Das sind dann genau die, die aus irgendeinem Grund von der vorigen Routine übergangen wurden.

Normalisierung, Tippfehler Quelle: dmt Datum: 03.2004

Auch sehr beliebt sind bei Normalisierungen die unüberschaubare Anzahl von Tippfehlern, Schreibvariationen etc. p.p., die dem Chef mit entsprechenden Group by / Having - Abfragen so richtig schön unter die Nase gerieben werden können, so daß den erstmal der Schlag trifft.

Del_Brackets entfernt z.B. für jeden Wert im angegebenen Feld der angegebenen Tabelle das angegebene, unerwünschte Zeichen. Das mit der vollmundig angekündigten Transaktion kann bei den traditionell beschränkten Resourcen, Heaps und Stacks und was auch sonst immer überlaufen mag, bei einer großen Menge an Daten auch schief gehen, aber in diesem Fall wurden an den bis zum Abbruch durchlaufenen Daten auch keine Änderungen vorgenommen. Hat zwar dann so nicht geklappt, aber trotzdem Bravo !

Sub Del_Brackets (sTabelle, sFeld)

    On Error GoTo err_Del_Brackets

    ' **** entfernt für jeden Datensatz im sFeld in sTabelle die ****
    ' **** eckigen Klammern [ und ], und das mit Transaktion !   ****

    Dim WS As WorkSpace, DB As Database, RS As Recordset
    Dim sReturn As String, i As Integer, v As Variant

    Set WS = DBEngine.Workspaces(0)
    Set DB = WS.Databases(0)
    Set RS = DB.OpenRecordset(sTabelle, DB_OPEN_TABLE)

    ' **** Anzahl der Datensätze in Quelltabelle ermitteln ****

    RS.MoveLast
    v = SysCmd(SYSCMD_INITMETER, "Öffne Datenquelle ...", RS.RecordCount)
    RS.MoveFirst

    'WS.BeginTrans

    ' **** Schleife durch alle Quelldaten ****

    Do While Not RS.EOF

       i = i + 1

       sReturn = ClearStringFrom(RS("Standort"), "[")
       sReturn = ClearStringFrom(sReturn, "]")

       If sReturn <> RS("Standort") Then
          RS.Edit
          RS("Standort") = sReturn
          RS.Update
       End If

       RS.MoveNext

       v = SysCmd(SYSCMD_UPDATEMETER, i)

    Loop

    'WS.CommitTrans

exit_Del_Brackets:

    v = SysCmd(SYSCMD_CLEARSTATUS)
    Exit Sub


err_Del_Brackets:

    'WS.Rollback
    Fehler "Del_Brackets"
    GoSub exit_Del_Brackets

End Sub

Protokoll Quelle: dmt Datum: 03.2004

BENUTZEREINGABEN ÜBERWACHEN / PROTOKOLL / PROTOKOLLIEREN

Die Funktion Protokoll wird in den Formularereignissen VorAktualisierung mit =Protokoll("geändert") und BeimLöschen mit =Protokoll("gelöscht") aufgerufen.

NachLöschBestätigung ist es zu spät, da MS-Access bereits den nächsten Datensatz angesteuert hat.

Das jeweilige, zu überwachende Formular muß allerdings an einer Stelle in der Routine hinterlegt werden.

Im geändert-Fall (tritt auch beim Neuanlegen von Datensätzen ein) werden alle Felder durchlaufen und ihre OldValues mit deren aktuellen gegenübergestellt und in ein Memo-Feld geschrieben. Die Erkennung neuer Datensätze in dieser Schleife wurde wegen diverser OLDVALUE-Problematiken fallengelassen, ebenso wie der Versuch, die Routine vollstaendig unabhängig von expliziten Formular-Verweisen zu machen. Spätestens beim Aufrufen der Protokolldatensätze, um, wenn möglich, die Originaldatensätze wieder anzuzeigen, muß bekannt sein, welches Feld mit welchem Wert zur Identifikation herangezogen werden soll.

Deswegen wird an einer Stelle auf das zu überwachende Formular explizit verwiesen. Hier wird entschieden, wie das Ident-Feld heißt, ob bei Ident=NULL ein neuer Datensatz vorliegt und was im Löschenfall alles in das Protokoll-Memo geschrieben werden soll.

Leider mußte auch die Kröte geschluckt werden, daß editierte Datensätze VorAktualisierung nicht mehr als NEU oder GEÄNDERT identifiziert werden können. Deshalb muß formularbezogen leider auch eine explizite Nennung der Datenherkunfts-Domäne erfolgen, um in einer DLookup-Anweisung anhand Feld, Domäne und Wert die Existenz des Datensatzes zu überprüfen.

Function Protokoll (sModus As String)

    ' Aufruf aus VorAktualisierung: =Protokoll("geändert")
    ' Aufruf aus NachLöschen:       =Protokoll("gelöscht")

    On Error GoTo err_Protokoll1

    DoCmd Hourglass True

    Dim F As Form
    Dim DB As Database, RS As Recordset
    Dim s As String, CR As String, sId As String, sTabelle As String
    Dim i As Integer, iLog As Integer

    Set F = Screen.ActiveForm

    CR = Chr$(13) & Chr$(10)

    ' **** Plausibilitäten ****

    If FlascheLeer(F.RecordSource) Then
       Beep
       MsgBox "Formular mit ungültiger Datenherkunft '" & F.Name & "' !", 16, "Protokoll"
       Resume exit_Protokoll
    End If

    Select Case sModus
        Case "geändert":    ' nix
        Case "gelöscht":    iLog = True: GoSub Protokoll_Log
        Case Else:          Beep
                            MsgBox "Ungültiger Wert '" & sModus & "' !", 16, "Protokoll"
                            Resume exit_Protokoll
    End Select

    ' **** Steuerelemente durchlaufen ****

    For i = 0 To F.Count - 1
        If Variant_Verschieden(F(i).OldValue, F(i)) = True Then
           iLog = True
           s = s & F(i).Name & ":  '" & F(i).OldValue & "' -> '" & F(i) & "'" & CR
        End If
Protokoll_weiternudeln:
    Next i

    ' **** Gegebenenfalls Protokolldatensatz anlegen ****

    On Error GoTo err_Protokoll2

    If Len(s) > 2 Then s = Left$(s, Len(s) - 2)  ' lösche letztes CR

Protokoll_Log:

    If iLog = True Then

       ' **** Formular-Identfeld zuweisen ****

       Select Case F.Name
           Case "Termine": sId = "ID"
                           sTabelle = "Termine"
                           If sModus = "gelöscht" Then
                              s = F!Suchname & " - " & F!Grund & " - " & F!Datum_von & " - " & F!Zeit_von & " - erl.: " & F!erledigt & CR & CR & F!Notiz
                           End If
           Case Else:      Beep
                           MsgBox "Ungültiges Formular '" & F.Name & "' !", 16, "Protokoll"
                           GoSub exit_Protokoll
       End Select

       ' **** Datensatz anlegen und Werte zuweisen ****

       Set DB = DBEngine.Workspaces(0).Databases(0)
       Set RS = DB.OpenRecordset("Protokoll", DB_OPEN_TABLE)

       RS.AddNew

       RS("Aktion") = sModus
       RS("Benutzer") = GetUser()
       RS("Formular") = F.Name

       RS("ID") = sId
       RS("Wert") = F(sId)
       RS("Info") = s

       If sModus = "geändert" Then

          If IsNumeric(F(sId)) = False Then
             s = sId & "='" & F(sId) & "'"
          Else
             s = sId & "=" & F(sId)
          End If

          If IsNull(DLookup(sId, sTabelle, s)) Then
             RS("Aktion") = "neu"
          End If

       End If

       RS.Update

    End If


exit_Protokoll:

    DoCmd Hourglass False

    Exit Function


err_Protokoll1:

    If Err = 2455 Or Err = 2427 Then
       Resume Protokoll_weiternudeln
    Else
       Fehler "Protokoll"
    End If

    Resume exit_Protokoll


err_Protokoll2:

    Fehler "Protokoll"

    Resume exit_Protokoll

End Function

Statusanzeige Quelle: dmt Datum: 03.2004

STATUSLEISTE / STATUSZEILE per Code einstellen:

Ein vereinfachtes Handling der Statuszeilen-Problematik:

Sub Statuszeile (Inhalt As String)

    On Error GoTo err_Statuszeile

    Dim v As Variant

    If Inhalt <> "" Then
       v = SysCmd(SysCmd_SetStatus, Inhalt)
    Else
       v = SysCmd(SysCmd_ClearStatus)
    End If

    Exit Sub


err_Statuszeile:

    Fehler "Statuszeile"
    Exit Sub

End Sub

Damit können z.Bsp. auch einheitliche Statuszeilen-Texte für die Seitenansicht von Berichten eingestellt werden, um den Anwender über praktischen ShortCuts zu informieren.

Im Ereignis Activate kann dann

    Statuszeile_Berichte

und in Deactivate

    Statuszeile ""

stehen.

Sub Statuszeile_Berichte ()

    On Error GoTo err_Statuszeile_Berichte

    Statuszeile "Seitenansicht:   schließt   Zoom   drucken  verschieben in vergrößerter Darstellung"

    Exit Sub


err_Statuszeile_Berichte:

    Fehler "Statuszeile_Berichte"
    Exit Sub

End Sub

Stichwortlisten Quelle: dmt Datum: 03.2004

STICHWORTLISTEN erstellen:

Dauert zwar sehr lange, tut aber. Per Distinct-Abfrage und in neue Tabelle einspielen können diese Daten zusammengefasst bearbeitet werden.

Private Sub Stichwortliste (sQuelltabelle As String, sQuellfeld As String)

    On Error GoTo err_Stichwortliste

    Dim DB As Database, RSQ As Recordset, RST As Recordset
    Dim v As Variant, i As Integer, iNumWords As Integer, iWord As Integer

    v = SysCmd(SYSCMD_SETSTATUS, "Tabellen werden geöffnet ...")

    Set DB = DBEngine.Workspaces(0).Databases(0)
    Set RSQ = DB.OpenRecordset(sQuelltabelle, DB_OPEN_TABLE)
    Set RST = DB.OpenRecordset("Stichwortliste", DB_OPEN_TABLE)

    RSQ.MoveLast
    v = SysCmd(SYSCMD_INITMETER, "Daten werden ausgelesen ...", RSQ.RecordCount)
    RSQ.MoveFirst

    Do While Not RSQ.EOF

       i = i + 1
       iWord = 1
       v = RSQ(sQuellfeld)

       If Not IsNull(v) Then
          iNumWords = SumWordsInStr(CStr(v))
          Do While iWord <= iNumWords
             RST.AddNew
             RST("Stichwort") = GetWordFromStr(iWord, CStr(v))
             RST.Update
             iWord = iWord + 1
          Loop
       End If

       v = SysCmd(SYSCMD_UPDATEMETER, i)
       RSQ.MoveNext
    Loop

    v = SysCmd(SYSCMD_REMOVEMETER)

    Exit Sub


err_Stichwortliste:

    Fehler "Stichwortliste"
    Exit Sub


End Sub

Später werden diese Daten per DISTINCT-Abfrage zusammengefasst und gegebenenfalls bereinigt in eine finale Stichworttabelle kopiert.

Tastaturbelegung anzeigen Quelle: dmt Datum: 05.2006

TASTATURBELEGUNGEN anzeigen:

Das Bereitstellen von Tastaturbelegungs-Makroeinträgen sowie eigenen Stammdaten-Menü, die in selbstgeschriebenen Standard-Menüs enthalten sind, bieten dem interessierten Anwender starke Möglichkeiten. Im Gegensatz zu relativ übersichtlichen Pulldown-Menü bleiben die eigenen ShortCuts aber im Dunkeln, so er denn keine gelben Klebezettel z.B. am Monitor hat.

Abhilfe schafft da diese Routine, die die entsprechenden Daten aus einer des MS-Access-Systemtabellen ausliest und in einer MsgBox anzeigt:

Function ShowShortCuts ()

    On Error GoTo err_ShowShortCuts

    Dim DB As Database, RS As Recordset
    Dim s As String, CR As String

    Set DB = DBEngine.Workspaces(0).Databases(0)
    Set RS = DB.OpenRecordset("SELECT Comments FROM MSysMacros WHERE ScriptName = 'Tastaturbelegung' And Comments <> '' ORDER BY Label")

    CR = Chr$(13) & Chr$(10)

    Do While Not RS.EOF
       s = s & RS.Comments & CR
       RS.MoveNext
    Loop

    s = Left$(s, Len(s) - 2)

    MsgBox s, 64, "Liste der Tastaturbelegungen"

    Exit Function


err_ShowShortCuts:

    Fehler "ShowShortCuts"
    Exit Function

End Function

Wenn jetzt noch im Kommentar-Makro-Eigenschaften-Feld die Tastaturkürzel a'la <Strg+Shift+x> gefolgt von Tabulatoren angegeben werden, kommt das in der MessageBox dann auch so richtig gut. s.a. bestatt.mdb

Umgebungsvariablen Quelle: dmt Datum: 03.2004

Mal wieder was Positives:

UMGEBUNGSVARIABLEN können per Environ$(x) bequem ausgelesen werden. Der Index beginnt unlogischerweise bei 1, naja, aber die Zahl kann beliebig sein (wird gerundet), es werden immerhin sauber begrenzte Strings (oder "") geliefert und man kann die Funktion wahlweise per Index oder Umgebungsvariablen-Name-String ansprechen.

Wenn also ein Environ$("Path") einen leeren String zurückgibt, dann wurde eben keine Path-Variable gesetzt bzw. sie enthält keinen Wert und man muß keine aufwendigen Index-Durchnudelungen vornehmen, um festzustellen, ob ein Eintrag auch enthalten ist, bevor man ihn fehlerlos abfragen darf.

Die folgende Routine dient nur noch zu Demonstrationszwecken:

Private Sub Show_Environment ()

    Dim i As Integer, s As String

    Do
        i = i + 1
        s = Environ$(i)
        If s <> "" Then
           MsgBox "'" & s & "'", , "Environment-Eintrag No." & i
           MsgBox "'" & Environ$(Left$(s, InStr(s, "=") - 1)) & "'", , "Wert der Umgebungsvariable '" & Left$(s, InStr(s, "=") - 1) & "'"
        Else
           Exit Do
        End If
    Loop

End Sub

Verzeichnisse Quelle: dmt Datum: 03.2004

ALLGEMEINES zu UNTERVERZEICHNISSEN und DATEI-OPERATIONEN

Das AKTUELLE ARBEITSVERZEICHNIS und SYSCMD_ACCESSDIR:

Die beiden Dinge ergeben leider nicht immer dasselbe.

Das aktuelle Arbeitsverzeichnis ist das, das uns z.Bsp. als Laufwerk/Pfad im Dialog 'Datei öffnen' präsentiert wird.

SYSCMD_ACCESSDIR liefert uns Laufwerk/Pfad, in dem die ausführbare Datei von MS-ACCESS bzw. Runtime-Modul (msarsch.exe) steht.

Das führt bei dem Versuch, Verzeichnis-Kacke innerhalb von MS-ACCESS und ausgelieferten Runtime-Installationen auf die Reihe zu kriegen, natürlich zu Problemen.

SYSCMD_ACCESSDIR liefert den Pfad, in dem die ausführbare ACCESS-Exe-Datei steht. Wenn aber auf das Verzeichnis Bezug genommen werden soll, in dem die MDB-Datei steht, in der die aktuelle Anwendung abläuft (that's where things are going on), sollte man sich darauf besser nicht verlassen. Das Abfragen der Eigenschaft 'Name' des Objektes

    DBEngine.Workspaces(0).Databases(0)

bringt hier das gewünschte Ergebnis. Für Unterverzeichnis-Operationen, für die genau das gebraucht wird, muß der String aber erst noch bereinigt werden, weil er hinten raus den Namen der Datenbank beeinhaltet.

siehe auch DataBase_Dir ().

Verzeichnisse, Datenbank Quelle: dmt Datum: 06.2004

Die folgende Funktion liefert Pfad der aktuellen Datenbank a'la 'C:\DAT013KL':

Function Database_Dir () As String

    On Error GoTo err_Database_Dir

    Dim DB As Database, p As Integer, x As Integer, s As String

    Set DB = DBEngine.Workspaces(0).Databases(0)

    s = DB.Name

    Do
        p = InStr(p + 1, s, "\")
        If p > 0 Then
           x = p
        Else
           Exit Do
        End If
    Loop

    Database_Dir = Left$(s, x - 1)


exit_Database_Dir:

    Set DB = Nothing

    Exit Function


err_Database_Dir:

    Fehler "Database_Dir"
    Resume exit_Database_Dir

End Function

Die folgende Funktion liefert den Namen der aktuellen Datenbank a'la 'TRANSACT.MDB':

Function Database_Filename () As String

    On Error GoTo err_Database_Filename

    Dim DB As Database, p As Integer, x As Integer, s As String

    Set DB = DBEngine.Workspaces(0).Databases(0)

    s = DB.Name

    Do
        p = InStr(p + 1, s, "\")
        If p > 0 Then
           x = p
        Else
           Exit Do
        End If
    Loop

    Database_Filename = Right$(s, Len(s) - x)

    Exit Function


err_Database_Filename:

    Fehler "Database_Filename"
    Exit Function

End Function

Eine allgemeine Funktion, die den reinen DATEINAMEN aus einer vollständigen Angabe wie z.B. 'e:\access\bosch\dat013kl\dat013kl.txt' ermittelt -> 'dat013kl.txt', ist:

Function Get_Filename (s As String) As String

    On Error GoTo err_Get_Filename

    Dim p As Integer, x As Integer

    Do
        p = InStr(p + 1, s, "\")
        If p > 0 Then
           x = p
        Else
           Exit Do
        End If
    Loop

    Get_Filename = Right$(s, Len(s) - x)

    Exit Function


err_Get_Filename:

    Fehler "Get_Filename"
    Exit Function

End Function

und dementsprechend für PFADE: (auch sinnvollerweise GetPathName benennbar)

Function Get_Dirname (s As String) As String

    On Error GoTo err_Get_Dirname

    Dim p As Integer, x As Integer

    Do
        p = InStr(p + 1, s, "\")
        If p > 0 Then
           x = p
        Else
           Exit Do
        End If
    Loop

    Get_Dirname = Left$(s, x - 1)

    Exit Function


err_Get_Dirname:

    Fehler "Get_Dirname"
    Exit Function

End Function

Verzeichnisse, Existenz Quelle: dmt Datum: 03.2004

Verzeichnis auf Existenz prüfen:

Function Exists_Dir(sDir As String) As Integer

    On Error GoTo err_Exists_Dir

    ' mußte geändert werden, da bei Dateinamen ohne Pfadbeigabe
    ' die Anweisung InStr(sFile, Dir$(sFile)) fälschlicherweise 1 ergibt.

    Dim s As String

    s = Dir$(sDir, vbDirectory)

    If InStr(sDir, s) And Len(s) > 0 Then
       Exists_Dir = True
    End If

    Exit Function


err_Exists_Dir:

    Fehler "Exists_Dir"
    Exit Function

End Function

Verzeichnisse, Inhalt Quelle: dmt Datum: 03.2004

DIR$ / VERZEICHNISINHALT ANZEIGEN:

Das folgende Beispiel arbeitet abhängig von einem positiven Ergebnis der Suchmuster-Angabe die Namen der ersten sowie aller weiteren Dateien, die dem eingangs verwendetem Dateikriterium entsprechen.

    Dim s As String

    s = Dir$(DataBase_Dir() & "\*.bmp")

    If Len(s) > 0 Then
        Do
            MsgBox s
            s = Dir
        Loop Until Len(s) = 0
        MsgBox "Keine weiteren Übereinstimmungen gefunden."
    Else
        MsgBox "Die angegebene Datei konnte nicht gefunden werden."
    End If


Einleuchtender finde ich die Version:

    sFile = Dir$(sImportPattern)
    If sFile <> "" Then                             ' Datei gefunden
       Do
          ' **** Dateianweisungen ****
          sFile = Dir
       Loop Until sFile = ""                        ' weitermachen
    Else
    End If

Eine Access97-Version mit Übergabe an ein sortiertes Array findet sich unter CrawlDir().

Verzeichnisse, prüfen, anlegen Quelle: dmt Datum: 03.2004

UNTERVERZEICHNIS prüfen, anlegen:

CheckDir prüft das Vorhandensein eines angegebenen Unterverzeichnisses unter dem Datenbank-Verzeichnis und bietet bei gesetztem Parameter das Anlegen an. Um ganz sicher zu gehen, wird zuerst das Laufwerk und dann das Verzeichnis auf das Datenbank-Verzeichnis gesetzt.

Function CheckDir (Dirname As Variant, iCreate As Integer) As Integer

    ' **** wechselt vom Datenbank-Verzeichnis testweise ****
    ' **** in das angegebene Unterverzeichnis, um fest- ****
    ' **** zustellen, ob es existiert und legt es bei   ****
    ' **** Bedarf an.

    On Error GoTo err_CheckDir

    Dim sDBDir As String

    sDBDir = Database_Dir()

Start_CheckDir:

    ChDrive sDBDir
    ChDir sDBDir
    ChDir Dirname
    ChDir sDBDir

    CheckDir = True

    Exit Function

err_CheckDir:

    If Err = 76 Then
       If iCreate = True Then
          Beep
          If MsgBox("Das Unterverzeichnis '" & Dirname & "' existiert nicht." & Chr$(13) & Chr$(10) & Chr$(13) & Chr$(10) & " Möchten Sie dieses Verzeichnis anlegen ?", 36, "Unterverzeichnis anlegen") = 6 Then
             MkDir Dirname
             Resume Start_CheckDir
          Else
             Exit Function
          End If
       Else
          Beep
          MsgBox "Das Unterverzeichnis '" & sDBDir & "\" & Dirname & "' existiert nicht !", 16, "Verzeichnis nicht vorhanden"
          Exit Function
       End If
    Else
       Fehler "CheckDir"
       Exit Function
    End If

End Function

* * * *

MkDir legt direkt ein angegebenes Verzeichnis auf dem angegebenen Datenträger an, aber leider nur mit einer 'Tiefe' von 1. Das kann im Bedarfsfall ganz schön schwierig werden und wenn die Daten nicht in einer aufbereiteten, sortierten Form a'la dmt.mdb / Formular Pflege_Ausgabe vorliegen, wo sie der Reihe und Tiefe nach abgearbeitet werden können, muß wohl umständlich mit CheckDir gearbeitet werden.

Verzeichnisse, rekursiv Quelle: dmt Datum: 03.2004

VERZEICHNIS-INHALTE / DATEIEN REKURSIV AUSLESEN / DURCHSUCHEN

Ein keineswegs profanes Thema.

Die Beispiele zeigen das Zusammenspiel der Routinen CrawlDirs und xDirArray:

Hier wird sogar ein zweidimensionales Array gebildet, um Verzeichnisnamen zum Vor-Sortieren sowie komplette Angaben (Pfad und Dateiname) getrennt handhaben zu können.

Grund war die Umsetzung des Wunsches, Dateien in Verzeichnissen sortiert in einem Array zu halten. Eine simple Sortierung konnte die Verzeichnis-Ebenen-Tiefe der Dateiliste nicht berücksichtigen.

So wurde das entsprechende "Arbeits"-Array

um eine Dimension erweitert, in der nur die Verzeichnis-Namen stehen.

Durch zwei Sortiervorgänge (erst nach Verzeichnissen und dann pro Verzeichnis nach den Inhalten der ersten Dimension) konnte das gewünschte Ziel erreicht werden.

Rund gemacht wird das Ganze in SortiereArray() mit anschließender Rückführung zu einem eindimensionalen Array in ReduziereArray().

Siehe auch das komplette Modul: (Access97 aus webmanag.mdb)

Verzeichnisse, übergeordnete Quelle: dmt Datum: 07.2004

Die Funktion nennt den Namen des Verzeichnis, das die Anzahl der angegebenen Ebenen über dem genannten liegt.

Function GetUpperDirectory (sDir As String, iLevel As Integer) As String

    On Error GoTo err_GetUpperDirectory

    Dim s As String, i As Integer, iPosLastSlash As Integer

    Const PATH_SEPARATING_SLASH = "\"

    ' **** Wie lautet das Verzeichnis, das die Anzahl von iLevel Ebenen über dem angegebenen steht ? ****

    s = sDir

    If Right$(s, 1) = PATH_SEPARATING_SLASH Then        ' evtl. Slash am Ende entfernen
       s = Left$(s, Len(s) - 1)
    End If

    ' Die Schleife wird ab iLevel=1 oder höher abgearbeitet.
    ' Ein zu hohes iLevel erzeugt den Fehler 5.

    Do While i < iLevel
       i = i + 1
       iPosLastSlash = LastInStr(s, PATH_SEPARATING_SLASH)
       s = Left$(s, iPosLastSlash - 1)
    Loop

    GetUpperDirectory = s

    Exit Function


err_GetUpperDirectory:

    If Err = 5 Then
       Beep
       MsgBox "Die Anzahl der angegebenen Ebenen (" & iLevel & ") ist zu hoch !" & Chr$(13) & Chr$(10) & Chr$(13) & Chr$(10) & "Das angegebene Verzeichnis lautet: '" & sDir & "'.", 16, "GetUpperDirectory"
    Else
       Fehler "GetUpperDirectory"
    End If

    Exit Function

End Function

Verzeichnisse, wechseln Quelle: dmt Datum: 03.2004

Oft ist es sinnvoll, ein bestimmtes Verzeichnis gesichert zum aktiven zu machen.
Was gab's da schon Ärger, wenn z.B. zip-executables in ihrem temp-Verzeichnis korrekt aufgerufen wurden und diese sich dann in ein ganz anderes Verzeichnis hinein auspacken wollten, weil dieses gerade das aktive Verzeichnis war.

ChDrive wechselt, wenn möglich, zum ermittelten Laufwerk, ChDir dann mit einer Eindringtiefe > 1 in das gewünschte Verzeichnis. Per Rückgabewert ist dann auch bekannt, ob die Sache erfolgreich war. Bei Diskette-nicht-im-Laufwerk-Fehler gibt's sogar Wiederholmöglichkeiten.

Function ForceDir (sDir As String) As Integer

    On Error GoTo err_ForceDir

    ' **** Wechselt auf jeden Fall in das vorhandene Verzeichnis sDir, ****
    ' **** auch wenn es auf einem anderen Laufwerk liegen sollte.      ****

    ChDrive sDir
    ChDir sDir

    ForceDir = True

    Exit Function


err_ForceDir:

    If Err = 71 Or Err = 76 Then
       Beep
       If MsgBox("Das (Disketten)-Laufwerk '" & sDir & "' ist nicht bereit." & Chr$(13) & Chr$(10) & Chr$(13) & Chr$(10) & "Legen Sie bitte den entsprechenden Datenträger in das Laufwerk ein.", 53, "Laufwerk nicht bereit") = 4 Then
          Resume
       End If
    Else
       Fehler "ForceDir"
    End If

    Exit Function

End Function

Vorlage, Standard, Datensätze, Schleife Quelle: dmt Datum: 07.2006

STANDARD-DURCHLAUFEN von DATENSÄTZEN:

So richtig schön mit Statuszeiger und Errorhandler:

    On Error goto err_Standard

    Dim i As Integer, v As Variant
    Dim DB As Database, RS As Recordset

    ' **** Variablen vereinbaren ****

    Set DB = DBEngine.Workspaces(0).Databases(0)
    Set RS = DB.OpenRecordset("Tabelle")    ', DB_OPEN_TABLE)

    ' **** Anzahl der Datensätze in Quelltabelle ermitteln ****

    RS.MoveLast
    v = SysCmd(SYSCMD_INITMETER, "öffne Datenquelle ...", RS.RecordCount)
    RS.MoveFirst

    ' **** Schleife durch alle Quelldaten ****

    Do While Not RS.EOF

       i = i + 1

       ' **** ANWEISUNG ****

       RS.MoveNext

       v = SysCmd(SYSCMD_UPDATEMETER, i)

    Loop

exit_Standard:

    v = SysCmd(SYSCMD_CLEARSTATUS)
    Exit Sub

err_Standard:

    Fehler "Standard"
    Resume exit_Standard

Vorlage, Standard, Sub, Objektvariablen Quelle: dmt Datum: 07.2006

VORLAGEN:

Standard-Sub mit Datenbank- und Recordset-Deklaration, Fehlerhandler sowie Access2- und -97-kompatiblen Destruktoren für die Objekt-Variablen:

Private Sub XYZ ()

    On Error GoTo err_XYZ

    Dim DB As Database, RS As Recordset
    Dim s As String, CR As String, sTab As String, v As Variant, i As Integer

    sTab = Chr$(9)
    CR = Chr$(13) & Chr$(10)

    Set DB = DBEngine.Workspaces(0).Databases(0)
    Set RS = DB.OpenRecordset("test", DB_OPEN_TABLE)

    v = SysCmd(SYSCMD_INITMETER, "Die Daten werden verarbeitet ...", RS.RecordCount)

    Do While Not RS.EOF
       i = i + 1
       v = SysCmd(SYSCMD_UPDATEMETER, i)
       RS.MoveNext
    Loop


exit_XYZ:

    v = SysCmd(SYSCMD_REMOVEMETER)
    Set RS = Nothing
    Set DB = Nothing
    Exit Sub


err_XYZ:

    Fehler "XYZ"
    Resume exit_XYZ

End Sub

Wählhilfe Quelle: dmt Datum: 03.2004

Die WÄHLHILFE / TELEFONIEREN über Access:

Geht, und zwar mit Hilfe des Wählhilfe-Assistenten. Was da wirklich passiert und welche Dateien man dazu braucht, steht natürlich nirgends. Schließlich werden da so interessante Dinge wie Umgang mit COM-Ports u.ä. abgecheckt, was ja laut Aussagen von microsoft selbst mit 'neueren' Visual Basic's Probleme bereiten soll oder mit Access-VB-Bordmitteln auch gar nicht geht.

Was kann bisher gesagt werden:

Der Aufruf erfolgt über eine Funktion wlib_Autodial, die einen String-Parameter erwartet.
Diese Funktion versucht, den übergebenen String zu bereinigen und einer globalen Variablen zuzuweisen. Anschließend wird nur ein Formular wlib_frmAutoDial geöffnet, in dem dann auch eine ganze Menge geschieht (bis zum Hinterlegen von Benutzereinstellungen für den ComPort in der win.ini).

Das Ganze steht komplett in wzlib.mda, die Funktion im Modul wlib_Entry.

Den Gedanken ans Extrahieren dieser ganzen Geschichte (von wegen Triumph des Willens) habe ich angesichts der Komplexität (Auslesen eigener Fehlertabellen, API ohne Ende und undurchsichtigstes Spiel mit globalen Variablen, schnell bleiben lassen, da schließlich alles schon in wzlib.mda steht, die meist wegen nützlicher Sachen wie

-Zoom-Fenster eh' schon (illegal) mitgeliefert wird.

Falls es mir aber doch einmal zu langweilig sein sollte, kann mit der Sub 'myDial' im Formular 'wlib_frmAutoDial' experimentiert werden. Ausser einem eigenem Datentyp sowie einer weiteren Sub und ein paar API-Funktionen passiert da gar nicht so viel, zudem muß dann auch nicht mit dem Wählhilfe-Dialog gearbeitet werden, der obendrein bei jedem 'Ok' die aktuellen Einstellungen in die win.ini reinschreibt, auch wenn gar nichts geändert wurde !