Diverser Code in Classic Visual Basic

Ermitteln des Textinhalts eines Word-Dokuments

Um den Text, der in einem Word-Dokument enthalten ist, zu bestimmen, kann Word automatisiert werden. Im Folgenden ist der Quellcode einer Prozedur GetWordDocumentText angegeben, die das Dokument öffnet, den Text ausliest und ihn als Rückgabewert der Funktionsprozedur zurückgibt. Es ist zu beachten, daß die Implementierung unoptimiert und nur als Lösungsskizze zu verstehen ist:

Private Function GetWordDocumentText( _
    ByVal FileName As String _
) As String
    With CreateObject("Word.Application")
        .Visible = False
        Call .Documents.Open(FileName, , True)
        Call .WordBasic.EditSelectAll
        Call .WordBasic.SetDocumentVar("MyVar", .WordBasic.Selection)
        GetWordDocumentText = _
            Replace(.WordBasic.GetDocumentVar("MyVar"), vbCr, vbNewLine)
        Call .Documents.Close(0)
        Call .Quit
    End With
End Function

Soll lediglich ein Word-Dokument im Textformat gespeichert werden, kann auf folgenden Code zurückgegriffen werden:

Dim WordApp As Word.Application
Set WordApp = New Word.Application
Dim WordDoc As Word.Document
Set WordDoc = WordApp.Documents.Open(FileName:=SourceFileName, Readonly:=True)
Call WordDoc.SaveAs(DestinationFileName, Word.WdSaveFormat.wdFormatDOSText)
Call WordApp.Quit

Öffnen einer Website im Standardwebbrowser

Die Funktion ShowWebsite kann eingesetzt werden, um eine Website im Standardbrowser anzuzeigen:

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
    ByVal hWnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long _
) As Long

Private Const SW_SHOWNORMAL As Long = 1&

Private Function ShowWebsite( _
    ByVal ParentForm As Form, _
    ByVal URL As String _
) As Long
    ShowWebsite = _
        ShellExecute( _
            ParentForm.hWnd, _
            "OPEN", _
            URL, _
            vbNullString, _
            vbNullString, _
            SW_SHOWNORMAL _
        )
End Function

Drucken von Text mit Ausrichtung

Um Text mit Ausrichtung auf dem Drucker auszugeben, kann folgende Funktion verwendet werden:

Private Sub PrintAlignedText( _
    ByVal s As String, _
    ByVal Alignment As AlignmentConstants _
)
    Select Case Alignment
        Case vbCenter
            Printer.CurrentX = _
                (Printer.ScaleWidth - Printer.TextWidth(s)) * 0.5
        Case vbLeftJustify
            Printer.CurrentX = 0
        Case vbRightJustify
            Printer.CurrentX = _
                Printer.ScaleWidth - Printer.TextWidth(s)
    End Select
    Printer.Print s
End Sub

Der Aufruf zum Ausdrucken von zentriertem Text könnte dann folgendermaßen aussehen:

Call PrintAlignedText("This is centered text!", vbCenter)

Zeilenweises Ausdrucken einer Textdatei

Diese Funktion wird verwendet, um eine Textdatei zeilenweise auf dem Drucker auszugeben. Tritt dabei ein Fehler auf, wird die Fehlernummer zurückgegeben:

Private Function PrintTextFile(ByVal FileName As String) As Long
    On Error Resume Next
    Dim s As String
    Open FileName For Input As #1
    Do While Not EOF(1)
        Line Input #1, s
        Printer.Print s
    Loop
    Call Printer.EndDoc
    Close #1
    PrintTextFile = Err.Number
End Function

Abspielen einer Melodie auf dem Systemlautsprecher

Unter Windows NT/Me/2000 ist es wieder möglich, Töne über den internen Lautsprecher des PCs auszugeben. Dies kann über die API-Funktion Beep geschehen. Damit läßt sich leicht der PLAY-Befehl von QuickBasic nachbauen:

Private Declare Sub Beep Lib "kernel32.dll" ( _
    Optional ByVal dwFreq As Long = 440, _
    Optional ByVal dwDuration As Long = 240 _
)

Private Sub Form_Click()
    
    ' "Alle meine Entchen" abspielen.
    Call Play("abcde e ffffe  ffffe  ddddc c bbbba")
End Sub

Private Sub Play(ByVal Sound As String)
    Dim i As Long
    Dim Note As String
    For i = 1 To Len(Sound)
        Note = Mid$(Sound, i, 1)
        Select Case Note
            Case "a": Call Beep(444)
            Case "b": Call Beep(488)
            Case "c": Call Beep(550)
            Case "d": Call Beep(580)
            Case "e": Call Beep(640)
            Case "f": Call Beep(720)
            Case "g": Call Beep(810)
            Case "h": Call Beep(860)
            Case "i": Call Beep(920)
            Case " ": Call Beep(32767)
        End Select
    Next i
End Sub

Formatieren von Zahlen für die Ausgabe

Die Anweisung Format$ kann verwendet werden, um Zahlen für die Ausgabe zu formatieren. Folgendes Beispiel zeigt, wie Zahlen schön nach dem Dezimaltrennzeichen rechts ausgerichtet werden, wie dies bei Rechnungen der Fall ist:

Debug.Print Format$(Format$(123.45, "0.00"), "@@@@@@@@")
Debug.Print Format$(Format$(3.4, "0.00"), "@@@@@@@@")
Debug.Print Format$(Format$(12345.6, "0.00"), "@@@@@@@@")

Die Ausgabe würde wie folgt aussehen:

  123.45
    3.40
12345.60

Folgender Code richtet die beiden Zahlen rechts bzw. links aus:

Debug.Print """" & Format$(123, "@@@@@@") & """"
Debug.Print """" & Format$(123, "!@@@@@@") & """"

Die Ausgabe würde dann aussehen, wie unten angegeben:

"   123"
"123   "

Umstellen des Papierformats in Word-VBA

Mit nachfolgendem Makro kann das Papierformat eines Dokuments zwischen Hoch- und Querformat umgeschaltet werden:

Public Sub SwapPaper()
    With ActiveDocument.PageSetup
        If .Orientation = wdOrientLandscape Then
            .Orientation = wdOrientPortrait
            .PageWidth = CentimetersToPoints(21)
            .PageHeight = CentimetersToPoints(29.7)
            Call MsgBox( _
                "Die Seiteneinstellungen wurden auf Hochformat umgestellt!", _
                vbInformation _
            )
        Else
            .Orientation = wdOrientLandscape
            .PageWidth = CentimetersToPoints(29.7)
            .PageHeight = CentimetersToPoints(21)
            Call MsgBox( _
                "Die Seiteneinstellungen wurden auf Querformat umgestellt!", _
                vbInformation _
            )
        End If
    End With
End Sub

Ermitteln der Zeitdifferenz zwischen jetzt und einem anderen Zeitpunkt

Die im Folgenden angegebene Funktion kann verwendet werden, um zu berechnen, wie lange es noch bis zu einem bestimmten Zeitpunkt dauert bzw. wieviel Zeit seither vergangen ist. Als Ausgabe wird eine formatierte Zeichenfolge mit der Zeitdifferenzangabe zurückgegeben, die Differenz wird intern über die Visual-Basic-Funktion DateDiff errechnet:

Private Sub Main()
    Call MsgBox( _
        "Time until 2/16/2002: " & _
        GetTimeUntilNow(#2/16/2002#) _
    )
End Sub

Private Function GetTimeUntilNow(ByVal EventDate As Date) As String
    Dim Days As Long, Hours As Long, Minutes As Long, Seconds As Long
    Dim TotalSeconds As Long
    TotalSeconds = DateDiff("s", Now, EventDate)
    Days = (TotalSeconds \ 86400)
    Hours = (TotalSeconds - Days * 86400) \ 3600
    Minutes = (TotalSeconds - Days * 86400 - Hours * 3600) \ 60
    Seconds = (TotalSeconds - Days * 86400 - Hours * 3600) - Minutes * 60
    GetTimeUntilNow = _
        CStr(Days) & " days, " & _
        Format$(Hours, "00") & ":" & _
        Format$(Minutes, "00") & ":" & _
        Format$(Seconds, "00")
End Function

Benutzen eines Excel-Arbeitsblatts als Datenbank

Auch wenn es manche nicht glauben, man kann auch Excel-Dateien mit ADO als Datenbank einsetzen:

Private m_cn As ADODB.Connection
Private m_rs As ADODB.Recordset

Private Sub Form_Load()
    Set m_cn = New ADODB.Connection
    Set m_rs = New ADODB.Recordset
    With m_cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties").Value = "Excel 8.0"
        Call .Open("C:\Programs\Data\MyDatabase.xls")
    End With
    With m_rs
        .ActiveConnection = m_cn
        .CursorLocation = adUseClient
        .Source = "SELECT * FROM Articles"  ' Tabellenname = Arbeitsblattname.
        Call .Open
    End With
    Set grdMyDataGrid.DataSource = m_rs
End Sub

Excel verwaltet sich intern als Datenbank, die Funktionen werden nur von Excel draufgesetzt. Aber nicht desto trotz sollte man nach Möglichkeit davon absehen, Excel als Datenbank zu nutzen.

Vertauschen zweier Zahlen

Um Zahlen zu vertauschen, stehen mehrere Möglichkeiten zur Verfügung. Die am öftesten verwendete Methode benutzt eine temporäre Variable, in die zuerst der Wert der ersten Variable abgelegt wird, dann wird diese Variable mit der anderen überschrieben, danach wird der zweiten Variablen der Wert der temporären Variablen zugewiesen. Im Folgenden wird ein Code angegeben, der dieses Verfahren implementiert:

Dim a As Long, b As Long, c As Long
c = a
a = b
b = c

Die oben angegebene Methode läßt sich auch bei anderen Datentypen einsetzen. Störend an diesem Verfahren ist die temporäre Variable, die immer neu angelegt werden muß. Klarerweise kann man diese durch eine globale Variable ersetzen, die immer wiederverwendet wird. Betrachtet man aber die Subtraktion von Zahlen genauer, kann man feststellen, daß sich die neuen Werte der beiden Variablen durch folgende Gleichungen ausdrücken lassen:

a = b - ( b - a )

b = a + ( b - a )

Mit diesem Wissen kann man den folgenden Algorithmus zum Austauschen der Werte der Variablen formulieren:

Private Sub Swap(ByRef a As Long, ByRef b As Long)
    a = b - a
    b = b - a
    a = b + a
End Sub

Der Operator Swap ist zwar gut und schön, allerdings gibt es doch einige Dinge, die beachtenswert sind:

Eine weitere Variante ist eine andere Schreibweise des vorigen Beispiels: Man verwendet dabei anstelle der numerischen Operationen bitweise exklusive Oder-Verknüpfungen. Dieses Verfahren ist in Visual Basic 6.0 sogar schneller als die Version mit den numerischen Operatoren.

Korrekte Verwendung der Funktion Now

Vorsicht mit dem Gebrauch der Funktion Now. Probieren Sie die folgenden beiden Beispiele:


' Liefert heutiges Datum vierstellig.
Ret1 = Format$(Now, "0000")

' Liefert heutiges Datum im Format TT.MM.JJJJ.
Ret2 = Format$(x, "DD.MM.YYYY")

Das obige Beispiel funktioniert nur vor 12 Uhr mittags, sollte es später sein, so rundet Visual Basic auf den nächsten Tag auf, da die Funktion Now einen Wert des Typs Variant liefert, der in diesem Fall auf den nächsten Tag aufgerundet wird. Mit der Int-Anweisung kann Abhilfe geschaffen werden:

Ret1 = Format$(Int(Now), "0000")
Ret2 = Format$(x, "DD.MM.YYYY")

Kaufmännisches Runden von Zahlen

Die Round-Funktion kann nicht kaufmännisch runden. Folgendes Beispiel würde 2 als Ergebnis liefern:

Call MsgBox(CStr(Round(2.5, 0)))

Verwendet man jedoch die die folgende Funktion, erhält man den kaufmännisch gerundeten Wert 3. Bei negativen Zahlen wird ein eigentlich nicht korrektes Resultat zurückgegeben, der Leser kann sich aber leicht überlegen, wie der Code richtig aussehen müßte:

Private Function MRound( _
    ByVal Number As Double, _
    ByVal Decimals As Integer _
) As Double
    MRound = Int(Number * 10 ^ Decimals + 0.5) / 10 ^ Decimals
End Function

Private Sub Main()
    
    ' Folgender Code rundet richtig auf n Nachkommastellen, hier 2.5 auf
    ' 0 Nachkommastellen.
    Call MsgBox(CStr(MRound(2.5, 0)))
    
    ' Folgender Code rundet richtig auf positive Ganzzahlen, 2.5 ist die
    ' zu rundende Zahl.
    Call MsgBox(CStr(Fix(2.5 + 0.5)))
End Sub

Entfernen eines Eintrags aus einem Array

Folgende Funktion kann eingesetzt werden, um ein Element aus einem Array zu entfernen. Es werden dabei alle nachfolgenden Elemente um einen Platz nach vor kopiert und das letzte Element entfernt. Diese Funktion hat aber im schlimmsten Fall lineare Laufzeit. Muß man aus einem Array Elemente entfernen, kann ggf. die Datenstruktur der linearen Liste bessere Resultate liefern, da hier die selbe Operation in konstanter Zeit durchgeführt werden kann, weil keine Elemente kopiert werden müssen:

Private Sub RemoveItemFromArray( _
    ByRef Array As Variant, _
    ByVal Index As Long _
)
    If Index <= UBound(Array) And Index >= LBound(Array) Then
        Dim i As Long
        For i = Index To UBound(Array)
            Array(Index) = Array(Index + 1)
        Next i
        ReDim Preserve Array(LBound(Array) To UBound(Array) - 1)
    End If
End Sub

Der Aufruf könnte folgendermaßen erfolgen:

Dim c() As Integer  ' Es muß sich um ein dynamisches Array handeln.
ReDim c(0 To 3) As Integer
c(0) = 2
c(1) = 22
c(2) = 23123
c(3) = 10
Call RemoveItemFromArray(c, 2)
Debug.Print c(2)    ' Dieses Element hat den Wert 10.
Debug.Print c(3)    ' Löst einen Fehler aus, da nicht mehr vorhanden.

Umwandeln von vorzeichenlosen in vorzeichenbehaftete Ganzzahlen

Um einen vorzeichenlosen Integer (im Bereich von 0 bis 65.536) in einen Visual-Basic-Integer zu konvertieren, um ihn z. B. an API-Funktionen zu übergeben, kann folgende Funktion verwendet werden:

Private Sub Main()
    Call MsgBox( _
        "UInt" & vbTab & "Int" & vbNewLine & _
        "0" & vbTab & UIntToInt(0) & vbNewLine & _
        "422" & vbTab & UIntToInt(422) & vbNewLine & _
        "21744" & vbTab & UIntToInt(21744) & vbNewLine & _
        "32767" & vbTab & UIntToInt(32767) & vbNewLine & _
        "43021" & vbTab & UIntToInt(43021) & vbNewLine & _
        "65536" & vbTab & UIntToInt(65536) _
    )
End Sub

Private Function UIntToInt(ByVal UInt As Long) As Integer
    If UInt <= 32767 Then               ' &H7FFF
        UIntToInt = CInt(UInt)
    Else
        UIntToInt = CInt(UInt - 65536)  ' &H10000
    End If
End Function

Zurücksetzen von Objekten für ihre erneute Verwendung

Bei der Verwendung von eigenen Klassen in Schleifen kommt es oft vor, daß nach jedem Durchlauf die Eigenschaften des Objekts zurückgesetzt werden. Im schlimmsten Fall handelt es sich dabei um eine große Anzahl von Eigenschaften und Variablen, die entweder öffentlich zugänglich sind oder innerhalb der Klasse durch eigene Methoden auf bestimmte Startwerte gesetzt werden. In diesem Fall werden viele Programmierer auf eine bedeutend einfachere Methode zurückgreifen.

Nehmen wir an, wir müssen in einer Schleife 1.000 mal eine Klasse einsetzen, um bestimmte Operationen durchzuführen. Zu beachten ist, daß wir an Position (1) im folgenden Code immer erwarten, daß alle internen Variablen der Klasse zurückgesetzt sind. Anstatt eine aufwendige Reset-Prozedur zu implementieren, die auch noch bei Änderungen der Mitglieder der Klasse angepaßt werden muß, machen es sich viele Programmierer leichter und setzen nach jedem Schleifendurchlauf die Klasse auf das Schlüsselwort Nothing, wodurch der Speicher freigegeben wird und damit auch alle Variablen gelöscht werden. Anschließend wird am Anfang der Schleife der Variablen dann wieder eine neue Instanz der Klasse zugewiesen:

Dim i As Long
Dim MyParser As CParser
For i = 1 To 1000
    Set MyParser = New CParser  ' (1)
    
    ' Set properties here and call various class methods.
    ' Many properties and vars are set to other values.
    
    Set MyParser = Nothing
Next i

Zusammenfassend kann gesagt werden, daß im obenstehenden Code immer für jeden Schleifendurchlauf Speicher (und das kann bei einer umfangreichen Klasse gar nicht so wenig sein) freigegeben und anschließend wieder neu belegt werden muß. So schnell Speicheroperationen auch sind, bei einer großen Anzahl von Durchläufen kann dies bereits sehr viel Zeit in Anspruch nehmen.

Wie bereits erwähnt, wäre es in den meisten Fällen effizienter, eine eigene Reset-Methode bzw. mehrere spezifische Reset-Methoden zu programmieren, in denen dann nur die entsprechenden Variablen zurückgesetzt werden. Dadurch entfällt die Freigabe des Speichers, das erneute Anfordern und das Setzen der Variablen auf die Anfangswerte. Der Code würde dann folgendermaßen aussehen:

Dim i As Long
Dim MyParser As CParser
Set MyParser = New CParser
For i = 1 To 1000
    
    ' Set properties here and call various class methods.
    ' Many properties and vars are set to other values.
    
    Call MyParser.Reset
Next i
Set MyParser = Nothing

Vergleichen zweier Instanzen eines benutzerdefinierten Datentyps

Variablen und Konstanten des gleichen Datentyps können mit dem Operator = auf Gleichheit getestet werden. Bei benutzerdefinierten Datentypen ist dies nicht so einfach möglich. Ein Ansatz, trotzdem zwei „Instanzen“ eines benutzerdefinierten Typs auf Gleichheit zu überprüfen besteht darin, die von den beiden Strukturen belegten Speicherbereiche in jeweils einer Zeichenfolge zu kopieren und diese dann zu vergleichen:

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
    ByVal pDst As String, _
    ByRef pSrc As Person, _
    ByVal ByteLen As Long _
)

Private Type Person
    Name As String * 100
    Age As Byte
    Size As Long
    Male As Boolean
End Type

Private Sub Form_Load()
    Dim p1 As Person
    With p1
        .Name = "Max Mustermann"
        .Age = 20
        .Size = 200
        .Male = True
    End With
    Dim p2 As Person
    With p2
        .Name = "Max Mustermann"
        .Age = 20
        .Size = 200
        .Male = True
    End With
    Call MsgBox(Equal(p1, p2))  ' Wahr.
    p2.Name = "Donald Duck"
    Call MsgBox(Equal(p1, p2))  ' Falsch.
End Sub

Private Function Equal(ByRef p1 As Person, ByRef p2 As Person) As Boolean
    Dim Length As Long
    Length = Len(p1)
    Dim s1 As String, s2 As String
    s1 = Space$(Length)
    s2 = s1
    Call CopyMemory(s1, p1, Length)
    Call CopyMemory(s2, p2, Length)
    Equal = (s1 = s2)
End Function