Zur Hauptseite ... Zum Onlinearchiv ... Zum Abonnement ... Zum Newsletter ... Zu den Tools ... Zum Impressum ... Zum Login ...

Gedrucktes Heft

Diesen Beitrag finden Sie in Ausgabe 7/2001.

Unser Angebot für Sie!

Lesen Sie diesen Beitrag und 500 andere sofort im Onlinearchiv, und erhalten Sie alle zwei Monate brandheißes Access-Know-how auf 72 gedruckten Seiten! Plus attraktive Präsente, zum Beispiel das bald erscheinende Buch 'Access 2010 - Das Grundlagenbuch für Entwickler'!

Diesen Beitrag twittern

Tipps und Tricks

Autor: Christoph Spielmann, Düsseldorf

Auf den folgenden Seiten versorgt Sie unser Autor Christoph Spielmann mit einigen Tipps und Tricks rund um VBA, die Sie sofort in Betrieb nehmen können. Hier finden Sie beispielsweise eine Möglichkeit, die Bildschirmauflösung zu ermitteln. Das kann u. a. für die Auslegung der Größe von For-mularen sehr interessant sein. Sie lernen, wie Sie Dateien entgültig löschen (ohne doppelten Boden, direkt in den Reißwolf) und wie Sie dem Anwender von Ihrer Applikation aus eine Möglichkeit zur Verfügung stellen, mal eben eine Diskette zu formatieren. Falls Sie einmal ein bestimmtes Systemverzeichnis auf Ihrer Festplatte vermissen - keine Sorge, hier finden Sie die richtige Funktion, um es wiederzufinden. Die nachfolgend beschriebenen Funktionen packen Sie am besten gut an eine sichere Stelle - Sie werden sie immer wieder benötigen.

Bildschirm nach Maß

Einige Office-Anwendungen stellen Ihnen die aktuelle Bildschirmgröße direkt zur Verfügung. So finden Sie beispielsweise in den Eigenschaften HorizontalResolution und VerticalResolution des System-Objekts der Word-Bibliothek die Breite und die Höhe des Bildschirms in Pixel:

Breite = System.HorizontalResolution

Höhe = System.VerticalResolution

Private Declare Function GetDC Lib "user32" _

    (ByVal hwnd As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" _

    (ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _

    (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Const HORZRES = 8

Private Const VERTRES = 10

Public Property Get ScreenHeightPixels() As Long

    Dim nDC As Long

    nDC = GetDC(0)

    ScreenHeightPixels = GetDeviceCaps(nDC, VERTRES)

    ReleaseDC 0, nDC

End Property

Public Property Get ScreenWidthPixels() As Long

    Dim nDC As Long

    nDC = GetDC(0)

    ScreenWidthPixels = GetDeviceCaps(nDC, HORZRES)

    ReleaseDC 0, nDC

End Property

Doch in der Access-Bibliothek fehlt diese Möglichkeit. Und in keiner der Bibliotheken der Office-Anwendungen finden Sie eine direkte oder indirekte Möglichkeit, die aktuelle Bildschirmauflösung in Erfahrung zu bringen (die Bildschirmauflösung hängt davon ab, ob der Anwender in den Bildschirmeinstellungen große oder kleine Bildschirmschriften oder eine beliebige Schriftgröße eingestellt hat).

Die gesuchten Werte liefert dagegen immer aktuell die API-Funktion GetDeviceCaps. Sie wird für den Gerätekontext (DC) eines bestimmten Geräts aufgerufen, etwa eines Druckers oder eben des Bildschirms.

Private Const LOGPIXELSX = 88

Private Const LOGPIXELSY = 90

Public Property Get dpiX() As Long

    Dim nDC As Long

    nDC = GetDC(0)

    dpiX = GetDeviceCaps(nDC, LOGPIXELSX)

    ReleaseDC 0, nDC

End Property

Public Property Get dpiY() As Long

    Dim nDC As Long

    nDC = GetDC(0)

    dpiY = GetDeviceCaps(nDC, LOGPIXELSY)

    ReleaseDC 0, nDC

End Property

Public Property Get TwipsPerPixelX() As Single

    Dim nDC As Long

    nDC = GetDC(0)

    TwipsPerPixelX = 1440 / _
        GetDeviceCaps(nDC, LOGPIXELSX)

    ReleaseDC 0, nDC

End Property

Public Property Get TwipsPerPixelY() As Single

    Dim nDC As Long

    nDC = GetDC(0)

    TwipsPerPixelY = 1440 / _
        GetDeviceCaps(nDC, LOGPIXELSY)

    ReleaseDC 0, nDC

End Property

Public Property Get ScreenHeightTWIPS() As Single

    Dim nDC As Long

    nDC = GetDC(0)

    ScreenHeightTWIPS = GetDeviceCaps(nDC, VERTRES) * _

     (1440 / GetDeviceCaps(nDC, LOGPIXELSY))

    ReleaseDC 0, nDC

End Property

Public Property Get ScreenWidthTWIPS() As Single

    Dim nDC As Long

    nDC = GetDC(0)

    ScreenWidthTWIPS = GetDeviceCaps(nDC, HORZRES) * _

        (1440 / GetDeviceCaps(nDC, LOGPIXELSX))

    ReleaseDC 0, nDC

End Property

Den Gerätekontext des Bildschirms erhalten Sie über die API-Funktion GetDC, der Sie als Fenster-Handle für den ganzen Bildschirm den Wert 0 übergeben.

Nach der Verwendung des Gerätekontextes müssen Sie daran denken, ihn wieder mit der API-Funktion ReleaseDC freizugeben.

Neben dem Gerätekontext übergeben Sie der Funktion GetDeviceCaps den jeweiligen Index, zu dem Sie den gewünschten Wert erhalten wollen. Über die beiden Hilfs-funktionen ScreenHeightPixels und ScreenWidthPixels erhalten Sie auf diese Weise z. B. die Bildschirmhöhe und die Bildschirmbreite.

In Quellcode 1 finden Sie zunächst die erforderlichen Deklarationen der benötigten API-Funktionen sowie der dazugehörenden Konstanten.

Die fehlende Information über die Bildschirmauflösung erhalten Sie über die Funktion GetDeviceCaps (Beispiele s. Quellcode 2). Sie liefert Ihnen direkt die vertikale und die horizontale Bildschirmauflösung in dpi (Dots per Inch).

Scheinbar sind die vertikale und die horizontale Auflösung immer gleich. Doch sollten Sie sich nicht darauf verlassen - es kann durchaus das eine oder andere Bildschirmgerät mit unterschiedlicher horizontaler und vertikaler Auflösung geben.

Aus der Bildschirmauflösung in dpi können Sie zusätzlich noch den vertikalen und den horizontalen Umrechnungsfaktor für die Maßeinheit TWIPS ermitteln.

Private Type SHFILEOPSTRUCT

    hWnd As Long

    wFunc As Long

    pFrom As String

    pTo As String

    fFlags As Integer

    fAnyOperationsAborted As Long

    hNameMappings As Long

    lpszProgressTitle As String

End Type

Quellcode 5

Private Declare Function SHFileOperation Lib _

    "Shell32.dll" Alias "SHFileOperationA" (lpFileOp _

    As SHFILEOPSTRUCT) As Long

Quellcode 6

Public Function Kill(Files As Variant, Optional ByVal _
    AllowUndo As Boolean, Optional ByVal ShowProgress _
    As Boolean, Optional ByVal Confirmation As _
    Boolean,  Optional ByVal Simple As Boolean, _

    Optional ByVal SysErrors As Boolean, Optional _
    ByVal hWnd As Long, Optional UserAborts As Variant _

    ) As Boolean

    Dim l As Long

    Dim nFileOperations As SHFILEOPSTRUCT

    Const FO_DELETE = &H3

    Const FOF_ALLOWUNDO = &H40

    Const FOF_SILENT = &H4

    Const FOF_NOCONFIRMATION = &H10

    Const FOF_SIMPLEPROGRESS = &H100

    Const FOF_NOERRORUI = &H400

Diese ist ein bei vielen externen Steuerelementen (wie etwa den Microsoft Common Controls) verwendeter Standard für bildschirmbezogene Abmessungen. Diese Maßeinheit errechnet sich als 1440stel der horizontalen bzw. vertikalen Bildschirmauflösung, wie sie von GetDeviceCaps geliefert wird (s. Quellcode 3).

Die Bildschirmgröße in TWIPS erhalten Sie dementsprechend über die Funktionen ScreenWidthTWIPS und ScreenHeightTWIPS (s. Quellcode 4)

Löschen, aber nicht richtig.

Eine Datei zu löschen ist in VBA ein Kinderspiel - zum Beispiel mit folgender Anweisung:

Kill "c:\autoexec.bat"

- und schon ist die Datei weg. Und zwar unrettbar verloren.

Vor allem bei vom Anwender ausgelösten Dateilöschungen sollten Sie ihm die Windows-übliche Möglichkeit einräumen, gelöschte Dateien und Ordner aus dem Papierkorb wieder herstellen zu können.

Verwenden Sie in solchen Fällen die API-Funktion SHFileOperation (s. Quellcode 6). Bei dieser können Sie wählen, ob die Datei(en) im Papierkorb landen, oder ob sie wie bei der VBA-Kill-Anweisung gleich vollständig gelöscht werden.

Außerdem können Sie die ge-wohnte Fortschrittsanzeige bieten und einige zusätzliche Einstellungen festlegen (SHFILEOPSTRUCT, Aussehen der Definition s. Quellcode 5).

Ebenso können Sie mit ihr komplette Ordner auf einen Schlag löschen - ein komplizierter, rekursiver Mechanismus mit den VBA-Anweisungen Kill und RmDir entfällt, da mit diesem Mechanismus alle untergeordneten Ordner geleert und einzeln gelöscht werden müssten.

    With nFileOperations

    If IsArray(Files) Then

        For l = LBound(Files) To UBound(Files)

            .pFrom = .pFrom & Files(l) & vbNullChar

        Next 'l

        .pFrom = .pFrom & vbNullChar

    ElseIf VarType(Files) = vbObject Then

        If TypeOf Files Is Collection Then

            For l = 1 To Files.Count

                .pFrom = .pFrom & Files(l) & vbNullChar

            Next 'l

            .pFrom = .pFrom & vbNullChar

        End If

    ElseIf VarType(Files) = vbString Then

        .pFrom = Files

        If Right$(.pFrom, 1) <> vbNullChar Then

            .pFrom = .pFrom & vbNullChar

        End If

        If Mid$(.pFrom, Len(.pFrom) - 1, 1) <> _
            vbNullChar Then

            .pFrom = .pFrom & vbNullChar

        End If

    End If

    If AllowUndo Then 

      .fFlags = FOF_ALLOWUNDO

    End If

    If Not ShowProgress Then

      .fFlags = .fFlags Or FOF_SILENT

    End If

    If Not Confirmation Then

      .fFlags = .fFlags Or FOF_NOCONFIRMATION

    End If

    If Simple Then

      .fFlags = .fFlags Or FOF_SIMPLEPROGRESS

    End If

    If Not SysErrors Then

      .fFlags = .fFlags Or FOF_NOERRORUI

    End If

    .wFunc = FO_DELETE

    .hWnd = hWnd

    Kill = Not CBool(SHFileOperation(nFileOperations))

    If Not IsMissing(UserAborts) Then

      UserAborts = CBool(.fAnyOperationsAborted)

    End If

    End With

End Function

Die hier vorgestellte Ersatzfunktion Kill (s. Quellcode 7) verhält sich wie das VBA-Original, wenn Sie ihr wie gewohnt lediglich den gewünschten Dateinamen übergeben.

Sie können dieser Ersatzfunktion aber auch ein dimensioniertes oder aktuell mit der Array-Funktion zusammengestelltes Array oder eine Collection aus einzelnen Datei- und Ordnerpfaden übergeben. Und Sie können Wildcards (etwa "*.*" oder "*.bas") verwenden.

Die gewünschte Funktionalität legen Sie in den einzelnen optionalen Parametern fest. Sollen die Dateien in den Papierkorb verschoben werden, setzen Sie AllowUndo gleich True. Soll der Windows-übliche Fortschrittsdialog mit der Möglichkeit zum Abbrechen des Vorgangs angezeigt werden, setzen Sie ShowProgress gleich True.

Die Rückfrage, ob wirklich gelöscht werden soll, legen Sie mit Confirmation gleich True fest. Eine etwas vereinfachte Fortschrittsanzeige, bei der die Anzeige der gerade bearbeiteten Dateinamen unterbleibt, wählen Sie mit Simple gleich True. Wenn Sie im Fall eines Fehlers die Windows-Anzeige dieses Fehlers beibehalten wollen, setzen Sie SysErrors gleich True.

Unabhängig davon, wie Sie den letztgenannten Parameter setzen, gibt die Funktion Kill den Wert True zurück, wenn ein Fehler aufgetreten ist. Allerdings lässt sich der Fehler nicht näher spezifizieren - Sie müssen auf andere Weise prüfen, was schief gegangen sein könnte, z. B. Datei nicht vorhanden, gesperrt u. Ä.

Hat der Anwender bei den gelegentlichen Rückfragen des Systems (wie etwa Löschen einer Systemdatei o. Ä.) beispielsweise einzelne Dateien übersprungen, können Sie diese Information über den Parameter UserAborts erhalten, in der Sie dazu eine Variable übergeben müssen. Allerdings bleibt Ihnen auch hierbei nur übrig, selbst herausfinden, welche Dateien übersprungen worden sind.

Private Declare Function GetDesktopWindow _
    Lib "user32" () As Long

Private Declare Function SHFormatDrive Lib "shell32" _
    (ByVal hWnd As Long, ByVal Drive As Long, ByVal _
    fmtID As Long, ByVal Options As Long) As Long

Public Enum fdReturnConstants

  fdRetSuccess = 0

  fdRetError = -1

  fdRetCancelled = -2

  fdRetNotFormattable = -3

  fdRetInvalidDrive = -4

End Enum

Das VBA-Original der Kill-Anweisung können Sie anstelle dieser erweiterten Kill-Funktion weiterhin jederzeit aufrufen. Dazu setzen Sie einfach den Herkunftsbezeichner (Qualifizierer) davor: "VBA.Kill ...".

Disketten mit Format

Sie möchten es dem Anwender ermöglichen, in Ihrem Programm eine Diskette frisch zu formatieren? Dann sollten Sie sich nicht lange mit der Entwicklung eigener Formatier-Routinen und Formatier-Dialoge aufhalten, sondern dem Anwender den entsprechenden Standard-Dialog anzeigen.

Zum einen ist die dahinter stehende Operation des Betriebssystems als ausgereift und stabil zu betrachten. Zum anderen ist der Standard-Dialog dem Anwender in der Regel vertraut. Außerdem hat er die Möglichkeit, sich zwischen der vollständigen Formatierung und der Schnellformatierung des Datenträgers zu entscheiden, und er kann auch einen Datenträgernamen angeben bzw. einen vorhandenen Namen ändern.

Diesen Standard-Dialog, der unter den verschiedenen Windows-Versionen unterschiedlich aussieht, aber dennoch im Wesentlichen die gleiche Funktionalität bietet, erreichen Sie über die API-Funktion SHFormatDrive. Die Funktion ist allerdings weder in im Windows-SDK dokumentiert noch sind Deklaration und Konstanten in den C-Header-Dateien enthalten.

Dennoch sollten Sie die Funktion bedenkenlos und auch zukunftssicher verwenden können, da Microsoft selbst in einem Artikel der Knowledge-Base die dokumentationsüblichen Informationen dazu liefert.

Die Funktion FormatDriveDlg vereinfacht den Aufruf der API-Funktion und bietet zugleich die Möglichkeit, das gewünschte Laufwerk sowohl über den Laufwerksbuchstaben als auch über die MS-DOS-übliche Nummer (beginnend ab 0, also Laufwerk A: gleich 0) zu spezifizieren.

Da der besagte Knowledge-Base-Artikel anmahnt, immer ein Fenster als Bezug zu übergeben, sollten Sie das entsprechende Fenster-Handle eines Forms (hWnd-Eigenschaft) verwenden.

Da im Grunde das Handle des Desktops genauso geeignet ist, können Sie im optionalen Parameter hWnd der Funktion FormatDriveDlg auch 0 übergeben oder ihn ganz weglassen. In der Funktion wird dann über die API-Funktion GetDesktopWindow automatisch das Handle des Desktops ermittelt und verwendet.

Den Erfolg der Aktion meldet die Funktion in ihrem Rückgabewert. Die möglichen Werte sind hier als enumerierte Konstanten bereitgestellt. Bricht der Anwender selbst den Dialog ab (Schaltfläche "Schließen"), ohne die Formatierung gestartet zu haben, wird fdRetCancelled zurückgegeben.

Wurde versehentlich die Kennung eines nicht-formatierbaren Laufwerks übergeben (etwa ein CD-ROM-Laufwerk), wird fdRetNotFormattable zurückgegeben. Alle übrigen Fehler auf Betriebssystemebene werden als fdRetError unspezifiziert gemeldet.

Während für diese Rückgabewerte die API-Funktion SHFormatDrive zuständig ist, wird der Rückgabewert fdRetInvalidDrive von der Funktion FormatDriveDlg selbst generiert, wenn ein "unmöglicher" Laufwerksbuchstabe oder eine entsprechende Laufwerksnummer übergeben worden ist.

Public Function FormatDriveDlg(Drive As Variant, _

   Optional ByVal hWnd As Long) As fdReturnConstants

   Dim nDriveNumber, nWnd As Long

   Const SHFMT_ID_DEFAULT = &HFFFF&

   Const SHFMT_OPT_FULL = 1

   If IsNumeric(Drive) Then

       Select Case CLng(Drive)

            Case 0 To 25

                nDriveNumber = CLng(Drive)

            Case Else

                FormatDriveDlg = fdRetInvalidDrive

                Exit Function

       End Select

   ElseIf VarType(Drive) = vbString Then

       Select Case UCase$(Left$(Drive, 1))

           Case "A" To "Z"

               nDriveNumber = _
                   Asc(UCase$(Left$(Drive, 1))) - 65

           Case Else

               FormatDriveDlg = fdRetInvalidDrive

               Exit Function

       End Select

   End If

   If hWnd = 0 Then

       nWnd = GetDesktopWindow()

   Else

       nWnd = hWnd

   End If

   FormatDriveDlg = SHFormatDrive(nWnd, nDriveNumber, _

        SHFMT_ID_DEFAULT, SHFMT_OPT_FULL)

End Function

Ordner mit System

Für die meisten Systemordner gibt es zwar Standardnamen und sie befinden sich meistens auch an Standardplätzen im Dateisystem.

Doch Ihre Programme sollten sich niemals darauf verlassen, dass etwa der Windows-Ordner unter C:\Windows zu finden ist - das Laufwerk kann ein anderes sein, ebenso kann der Ordnername anders lauten (unter Windows NT/2000 heißt dieser Ordner beispielsweise WINNT).

Doch über die API-Funktionen GetWindowsDirectory, GetSystemDirectory und GetTempPath können Sie jederzeit den tatsächlichen Pfad des Windows-, System- und des Temp-Ordners ermitteln.

Diese API-Funktionen geben jedoch - entgegen der VBA-Funktion - keinen String zurück. Sie erwarten stattdessen als Parameter einen vorbereiteten String, einen so genannten Puffer, in dem Sie das gewünschte Ergebnis ablegen können.

Private Declare Function GetSystemDirectory Lib _
    "kernel32" Alias "GetSystemDirectoryA" (ByVal _
    lpBuffer As String, ByVal nSize As Long) As Long

Private Declare Function GetTempPath Lib "kernel32" _

    Alias "GetTempPathA" (ByVal nBufferLength As Long, _
    ByVal lpBuffer As String) As Long

Private Declare Function GetWindowsDirectory Lib _
    "kernel32" Alias "GetWindowsDirectoryA" (ByVal _
    lpBuffer As String, ByVal nSize As Long) As Long

Private Const kLength = 255&

Quellcode 10

Public Function GetSysDir(Optional ByVal AddBackslash _
    As Boolean) As String

    Dim nBuffer As String

    Dim nReturn As Long

    e(kLength)

    nReturn = GetSystemDirectory(nBuffer, kLength)

    If nReturn > 0 Then

        If AddBackslash Then

            GetSysDir = Left(nBuffer, nReturn) & "\"

        Else

            GetSysDir = Left(nBuffer, nReturn)

        End If

    End If

End Function

Public Function GetTempDir(Optional ByVal AddBackslash _
    As Boolean) As String

    Dim nBuffer As String

    Dim nReturn As Long

    nBuffer = Space(kLength)

    nReturn = GetTempPath(kLength, nBuffer)

    If nReturn > 0 Then

        If AddBackslash Then

            GetTempDir = Left(nBuffer, nReturn)

        Else

            GetTempDir = Left(nBuffer, nReturn - 1)

        End If

    End If

End Function

Die Länge dieses Strings ist ausreichend zu wählen, damit Windows nicht über das Ende des Strings hinaus ins "Speicher-Outback" schreibt, was zu schweren Systemabstürzen führen kann. Im Rückgabewert dieser API-Funktionen erhalten Sie die tatsächliche Länge des im Puffer abgelegten Strings.

Die beiden Funktionen GetWindowsDirectory und GetSystemDirectory gleichen sich von der Syntax her. Im ersten Parameter wird der Puffer-String übergeben, im zweiten dessen Länge. Bei GetTempPath ist die Parameter-Reihenfolge genau umgekehrt - warum das so ist, weiß wohl niemand mehr so genau (Deklaration der Funktionen s. Quellcode 10).

Ebenfalls unterschiedlich ist der Abschluss des zurückgegebenen Pfades. GetTempPath schließt den im Puffer zurückgegebenen Pfad mit einem Backslash ("\") ab, GetWindowsDirectory und GetSystemDirectory hingegen tun dies nicht.

Damit Sie sich die ganze Pufferei samt den Parameter- und Rückgabe-Unterschieden sparen können, verpacken wir die drei API-Funktionen in einem Standard-Modul modWinSysDirs in handliche, VB-gewohnte Funktionen (s. Quellcode 11-13). Ob der von diesen Funktionen zurückgegebene Pfad mit einem Backslash abschließt, legen Sie mit dem optionalen Parameter AddBackslash fest.

Public Function GetWinDir(Optional ByVal AddBackslash _
    As Boolean) As String

    Dim nBuffer As String

    Dim nReturn As Long

    nBuffer = Space(kLength)

    nReturn = GetWindowsDirectory(nBuffer, kLength)

    If nReturn > 0 Then

        If AddBackslash Then

            GetWinDir = Left(nBuffer, nReturn) & "\"

        Else

            GetWinDir = Left(nBuffer, nReturn)

        End If

    End If

End Function

Public Function GetTempDir2(Optional ByVal _
    AddBackslash  As Boolean) As String

    Dim nTempDir As String

    On Error Resume Next

    nTempDir = Environ$("temp")

    If Len(nTempDir) = 0 Then

        nTempDir = Environ$("tmp")

    End If

    If Len(nTempDir) Then

        If AddBackslash Then

            GetTempDir2 = nTempDir & "\"

        Else

            GetTempDir2 = nTempDir

        End If

    End If

End Function

Ist dieser False oder fehlt er, schließt der zurückgegebene Pfad nicht mit einem Backslash ab. Schlägt der Aufruf der jeweiligen API-Funktion fehl, wird einfach ein leerer String zurückgegeben.

Die drei Funktionen GetSysDir, GetTempDir und GetWinDir machen sich die API-Funktionen zunutze, um die entsprechenden Verzeichnisse zu ermitteln.

Eine Alternative zur Ermittlung des Temp-Ordners über die API-Funktion soll hier nicht verschwiegen werden. In der Regel ist der Temp-Ordner auch in den Umgebungs-variablen des Systems abgelegt und kann daher über die VB-Funktion Environ$ ausgelesen werden.

"Alte Hasen" wissen allerdings, dass man den Temp-Ordner in zwei verschieden lautenden Umgebungsvariablen finden kann - meistens unter TEMP, gelegentlich aber auch unter TMP.

Das liegt daran, dass sich die Entwicklerwelt nie ganz einig darüber war, unter welcher dieser beiden Umgebungsvariablen der Temp-Ordner ordnungsgemäß anzugeben und zu finden sein sollte.

Manche Anwendungen verwenden die eine, manche die andere Bezeichnung. Es kann aber auch sein, dass auf einem System gerade die falsche, oder gar keine Angabe festgelegt worden ist.

Falls Ihnen das Hantieren mit API-Funktionen suspekt erscheinen sollte, können Sie den Temp-Ordner auch über die Funktion GetTempDir2 ermitteln.

Wechselspiel

Anders als VBA kennen die meisten Programmiersprachen (und auch andere Basic-Dialekte) inkrementierende und dekrementierende Operatoren oder Anweisungen und auch eine Anweisung zum Vertauschen der Inhalte zweier Variablen.

Private Declare Sub InterlockedIncrement Lib _
    "kernel32" (lpAddend As Long)

Private Declare Sub InterlockedDecrement Lib _
    "kernel32" (lpAddend As Long)

Quellcode 15

Public Sub Inc(Var As Variant, Optional ByVal _
    Increment As Long = 1)

    Var = CLng(Var) + Increment

End Sub

Public Sub IncI(Var As Integer, Optional ByVal _
    Increment As Integer = 1)

    Var = Var + Increment

End Sub

Public Sub IncL(Var As Long, Optional ByVal Increment _
    As Long = 1)

    If Increment = 1 Then

        InterlockedIncrement Var

    Else

        Var = Var + Increment

    End If

End Sub

Public Sub IncS(Var As Single, Optional ByVal _
    Increment As Single = 1)

    Var = Var + Increment

End Sub

Public Sub IncD(Var As Double, Optional ByVal _
    Increment As Double = 1)

    Var = Var + Increment

End Sub

Public Sub Dec(Var As Variant, Optional Decrement _
    As Long = -1)

    Var = CLng(Var) + Decrement

End Sub

Public Sub DecI(Var As Integer, Optional Decrement As _
    Integer = -1)

    Var = Var + Decrement

End Sub

Public Sub DecL(Var As Long, Optional Decrement As _
    Long = -1)

    If Decrement = 1 Then

        InterlockedDecrement Var

    Else

        Var = Var + Decrement

    End If

End Sub

Quellcode 16 (Teil 1)

VBA erwartet dagegen von Ihnen zum Inkrementieren bzw. Dekrementieren eine etwas umständliche Schreibweise, etwa:

A = A + 1

B = B - 1

Und zum Vertauschen ist eine Hilfsvariable notwendig:

H = A

A = B

B = H

Das Windows-API bietet hierbei keine brauchbare Unterstützung oder Verkürzung. Es gibt zwar Funktionen wie InterlockedIncrement, InterlockedDecrement und InterlockedExchange (Deklaration s. Quellcode 15), die zwar etwas schneller sind, als der Weg in reinem VBA, jedoch sind sie lediglich für Werte des Datentyps Long geeignet. Außerdem sind sie eigentlich gar nicht in erster Linie für diesen Zweck vorgesehen, wie aus den Dokumentationen hervorgeht.

Zur Einsparung der umständlichen Schreibweisen können Sie diese in Hilfsfunktionen verpacken und in ein Standard-Modul auslagern. Die Funktionen aus Quellcode 16 enthalten Implementierungen für alle Datentypen - jeweils einmal in der allgemeinen Form für Variants (jedoch wegen der Variant-Verwendung etwas langsamer) und in spezialisierten Formen für die Datentypen Integer, Long, Single und Double.

Public Sub DecS(Var As Single, Optional Decrement As _
    Single = -1)

    Var = Var + Decrement

End Sub

Public Sub DecD(Var As Double, Optional Decrement As Double = -1)

  Var = Var + Decrement

End Sub

Public Function IncTo(Var As Variant, ToVar As _
    Variant, Optional ByVal Increment As Long = 1) As _
    Boolean

    Dim nVar As Variant

    nVar = CLng(Var) + Increment

    If nVar <= CLng(ToVar) Then

        Var = nVar

        IncTo = True

    End If

End Function

Public Function IncToI(Var As Integer, ToVar As _
    Integer, Optional ByVal Increment As Integer = 1) _
    As Boolean

    Dim nVar As Integer

    nVar = Var + Increment

    If nVar <= ToVar Then

        Var = nVar

        IncTo = True

    End If

End Function

Public Function IncToL(Var As Long, ToVar As Long, _

    Optional ByVal Increment As Long = 1) As Boolean

    Dim nVar As Long

    nVar = Var + Increment

    If nVar <= ToVar Then

        Var = nVar

        IncTo = True

    End If

End Function

Public Function IncToS(Var As Single, ToVar As Single, _

    Optional ByVal Increment As Single = 1) As Boolean

    Dim nVar As Single

    nVar = Var + Increment

    If nVar <= ToVar Then

        Var = nVar

        IncTo = True

    End If

End Function

Die Funktionen übergeben den Sub-Prozeduren die zu inkrementierende bzw. dekrementierende Variable als Parameter und optional den Wert des Inkrements bzw. Dekrements (Voreinstellung 1 bzw. -1).

Beispiele:

Dim A As Variant

A = 10

Inc A

ergibt A = 11;

Dim B As Long

B = 100

Dec B

ergibt 99;

Dim C As Single

C = 5,5

Inc C, 0,5

ergibt 6.

Die Prozeduren dazu finden Sie in Quellcode 16.

Ein wenig spezialisierter sind die Funktionen IncTo und DecTo bzw. deren datentypspezifische Varianten. Sie inkrementieren oder dekremen-tieren einen Wert um einen bestimmten Wert, solange er unter einer vorgegebenen Obergrenze bzw. über einer vorgegebenen Untergrenze liegt. Im Prinzip beruhen For-Schleifen auf diesem Prinzip. IncTo und DecTo haben jedoch den Vorteil, dass die vorgegebenen Ober- bzw. Untergrenzen nicht exakt getroffen werden müssen, um die Schleife zu beenden, wenn der Grenzwert nicht durch das Inkrement bzw. das Dekrement teilbar ist.

Public Function IncToD(Var As Double, ToVar As Double, _

    Optional ByVal Increment As Double = 1) As Boolean

    Dim nVar As Double

    nVar = Var + Increment

    If nVar <= ToVar Then

        Var = nVar

        IncTo = True

    End If

End Function

Quellcode 17 (Teil 2)

Public Function DecTo(Var As Variant, Optional ToVar _
    As Variant, Optional ByVal Increment As Long = 1) _
    As Boolean

    Dim nVar As Variant

    nVar = CLng(Var) + Increment

    If nVar >= CLng(ToVar) Then

        Var = nVar

        DecTo = True

    End If

End Function

Quellcode 18

Private Declare Function InterlockedExchange Lib _
    "kernel32" (lpVar1 As Long, ByVal Var2 As Long) _
    As Long

Public Sub Swap(Var1 As Variant, Var2 As Variant)

    Dim nVar As Variant

    If IsObject(Var1) And IsObject(Var2) Then

        Set nVar = Var1

        Set Var1 = Var2

        Set Var2 = nVar

    ElseIf IsObject(Var1) Then

        Set nVar = Var1

        Var1 = Var2

        Set Var2 = nVar

    ElseIf IsObject(Var2) Then

        nVar = Var1

        Set Var1 = Var2

        Var2 = nVar

    Else

        nVar = Var1

        Var1 = Var2

        Var2 = nVar

    End If

End Sub

Quellcode 19

So können Sie mit IncTo beispielsweise den Ausgangswert 2 in einer Do...Loop-Schleife um 5 erhöhen, bis die Obergrenze von 30 erreicht wird. So lange eine Inkrementierung erfolgt, gibt die Funktion IncTo den Rückgabewert True zurück. Bei der letzten Inkrementierung beim Stand von 27 würde der Grenzwert 30 überschritten - der Wert wird nun nicht mehr erhöht und die Funktion gibt den Wert False zurück, sodass die Schleife verlassen wird:

Dim A As Integer

A = 2

Do While IncTo(A, 30, 5)

  '...

Loop

Die Funktionen IncTo und deren Varianten finden Sie in Quellcode 17, die Funktion DecTo in Quellcode 18. Die datentypspezifischen Varianten der Funktion DecTo lassen sich leicht anhand der entsprechenden Varianten der Funktion IncTo ableiten.

Ähnlich wie Inc und Dec kapseln die Prozeduren zum Vertauschen der Inhalte zweier Variablen die umständliche VBA-Syntax (nur beim Datentyp Long wird die schnellere API-Funktion InterlockedExchange verwendet). Bei der allgemeinen Variante wird sogar berücksichtigt, dass einer der beiden Werte oder beide Werte Objekte sein können, bei denen die Zuweisungen mit der Set-Anweisung erfolgen müssen. Ebenso kommt dementsprechend die spezialisierte Variante SwapObj dazu. Und für Datumswerte gibt es schließlich noch die Variante SwapDate. In den folgenden Prozeduren setzen Sie statt <Tausch-Algoritmus> jeweils die drei folgenden Zeilen ein:

nVar = Var1

Var1 = Var2

Var2 = nVar

Public Sub SwapI(Var1 As Integer, _
    Var2 As Integer)

    Dim nVar As Integer

    <Tausch-Algoritmus>

End Sub

Public Sub SwapL(Var1 As Long, _
    Var2 As Long)

    Var2 = InterlockedExchange(Var1, _
    Var2)

End Sub

Public Sub SwapS(Var1 As Single, _
    Var2 As Single)

    Dim nVar As Single

    <Tausch-Algoritmus>

End Sub

Public Sub SwapD(Var1 As Double, _
    Var2 As Double)

    Dim nVar As Double

    <Tausch-Algoritmus>

End Sub

Public Sub SwapDate(Var1 As Date, _
    Var2 As Date)

    Dim nVar As Date

    <Tausch-Algoritmus>

End Sub

Nachkommastellen abtrennen

Da es keine Funktion gibt, die den Nachkomma-Anteil einer Zahl zurückgibt, können Sie diesen auf einem kleinen Umweg erhalten. Sie subtrahieren einfach den ganzzahligen Anteil von der Zahl. Den ganzzahligen Anteil erhalten Sie über die relativ unbekannte VBA-Funktion Fix. Die Funktion Fix schneidet tatsächlich nur den Nachkommaanteil ab, im Gegensatz zu Funktionen wie Int, CInt oder CLng, die stattdessen automatisch runden.

Decimals = Number - Fix(Number)

Eine weitere Möglichkeit besteht mit den praktischen datentypspezifischen Hilfsfunktionen (Double als Standard-Ausführung):

Public Function GetDecimals(ByVal _
    Number As Double) As Double

    GetDecimals = Number - Fix(Number)

End Function

Public Function GetDecimalsS(ByVal _
    Number As Single) As Single

    GetDecimalsS = Number - Fix(Number)

End Function

Public Function GetDecimalsC(ByVal _
    Number As Currency) As Currency

    GetDecimalsC = Number - Fix(Number)

End Function

Ausblick

In den Umgebungsvariablen ist eine einfache Möglichkeit verborgen, die aktuelle Windows-Version zu ermitteln. Unter Windows NT und Windows 2000 enthält die Umgebungsvariable OS die Kennung Windows_NT, während diese Umgebungsvariable unter Windows 9x unbekannt ist. Zur weiteren Unterscheidung zwischen Windows NT und Windows 2000 können Sie die Umgebungsvariable PROGRAMFILES heranziehen, die wiederum unter Windows NT unbekannt ist, während sie unter Windows 2000 den Pfad des Programm-Ordners liefert.

Public Enum WinVersionConstants

  wvWin9x

  wvWinNT

  wvWin2000

End Enum

Public Function WindowsVersion() _
    As WinVersionConstants

    Select Case True

        Case Len(Environ$("OS")) = 0

            WindowsVersion = wvWin9x

        Case Len(Environ$ _
            ("PROGRAMFILES")) = 0

            WindowsVersion = wvWinNT

        Case Else

            WindowsVersion = wvWin2000

    End Select

End Function

Dem "Zufall" sei Dank.

Der interne Zufallszahlengenerator in Visual Basic, der über die Funktion Rnd Zufallszahlen liefern soll, ist eigentlich gar keiner. Er geht bei der Generierung von Zufallszahlen immer vom gleichen Ursprung aus und liefert immer wieder die gleiche Zahlenfolge.

Zufall kommt erst dann ins Spiel, wenn Sie mindestens vor dem ersten Aufruf der Rnd-Funktion zusätzlich noch die Funktion Randomize aufrufen. Ihr können Sie einen beliebigen Initialisierungswert als Parameter übergeben.

Um dem Zufall einigermaßen auf die Sprünge zu helfen, sollte dieser Wert auch möglichst zufällig sein, etwa der aktuelle Wert, den die Timer-Funktion zurückgibt (z. B. die Anzahl der seit Mitternacht vergangenen Sekunden).

Eine ganzzahlige Zufallszahl innerhalb eines gegebenen Zahlenbereichs erhalten Sie über die Rnd-Funktion nach folgender Formel:

Zahl = Int((Obergrenze - Untergrenze + 1) * Rnd + Untergrenze)

Die folgende Funktion RndNum liefert nach dieser Formel und optionaler Initialisierung der Zufallsbasis eine ganze Zahl innerhalb der Grenzen von LBnd und UBnd:

Public Function RndNum(ByVal LBnd As _
    Long, ByVal UBnd As Long, Optional _
    ByVal DoRandomize As Boolean) As Long

    If DoRandomize Then

        Randomize Timer

    End If

    RndNum = Int((UBnd - LBnd + 1) * _
        Rnd + LBnd)

End Function

Falls Sie gleich mehrere Zufallszahlen aus einem Zahlenbereich benötigen, können Sie die Funktion RndSet verwenden. Sie geben die gewünschte Anzahl an und bekommen die Zahlen wahlweise in einer Collection (Voreinstellung) oder als Array geliefert.

Public Function RndSet(ByVal Count As _
    Long, ByVal LBnd As Long, ByVal _
    Ubnd As Long, Optional ByVal _
    DoRandomize As Boolean = True, _

    Optional ByVal AsArray As Boolean) _
    As Variant

    Dim nNumbers As Collection

    Dim nRnd, nRndTest As Long

    Dim nRndSetArray() As Long

    Dim l As Long

    If DoRandomize Then

        Randomize Timer

    End If

    Set nNumbers = New Collection

    With nNumbers

        On Error Resume Next

        Do

            nRnd = RndNum(LBnd, UBnd)

            nRndTest = _
                nNumbers(CStr(nRnd))

            If Err.Number Then

                Err.Clear

                .Add nRnd, CStr(nRnd)

            End If

        Loop Until .Count = Count

    End With

    If AsArray Then

        ReDim nRndSetArray(1 To Count)

        For l = 1 To Count

            nRndSetArray(l) = nNumbers(l)

        Next

        RndSet = nRndSetArray

    Else

        Set RndSet = nNumbers

    End If

End Function

Zahlengruppen nach dem Muster 6 aus 49 für Ihren Lottoschein ermitteln Sie beispielsweise folgendermaßen:

Dim nLotto As Collection

Dim i As Integer

Set nLotto = RndSet(6, 1, 49)

For i = 1 To 6

  Debug.Print nLotto(i)

Next 'i

Kompletten Artikel lesen?

Einfach für den Newsletter anmelden, dann lesen Sie schon in einer Minute den kompletten Artikel und erhalten die Beispieldatenbanken.

E-Mail:

© 2003-2015 André Minhorst Alle Rechte vorbehalten.