Code zum Betriebssystem in Classic Visual Basic

Aufklappen des Startmenüs

Das Startmenü von Windows kann durch Auslösen von Tastaturereignissen geöffnet werden. Entweder man sendet direkt die linke Windows-Taste oder man löst Strg+Esc aus:

Private Declare Sub keybd_event Lib "user32.dll" ( _
    ByVal bVk As Byte, _
    ByVal bScan As Byte, _
    ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long _
)

Private Const KEYEVENTF_KEYUP As Long = &H2&

Private Const VK_LWIN As Byte = &H5B
Private Const VK_APPS As Byte = &H5D
Private Const VK_CONTROL As Byte = &H11
Private Const VK_ESCAPE As Byte = &H1B

' Diese Methode drückt die linke Windows-Taste.
Call keybd_event(VK_LWIN, 0, 0&, 0&)
Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0&)

' Hier wird die Tastenkombination Strg+Esc ausgelöst, wodurch das Startmenü
' aufgeklappt wird.
Call keybd_event(VK_CONTROL, 0, 0&, 0&)
Call keybd_event(VK_ESCAPE, 0, 0&, 0&)
Call keybd_event(VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0&)
Call keybd_event(VK_CONTROL, 0, KEYEVENTF_KEYUP, 0&)

Anzeigen aller Umgebungsvariablen

Visual Basic stellt die Funktion Environ$ zur Verfügung, um Umgebungsvariablen auszulesen. Um alle Variablen zu ermitteln, kann folgender Code verwendet werden:

Dim i As Integer
i = 1
Do
    Print Environ$(i)
    i = i + 1
Loop Until Len(Environ$(i - 1)) = 0

Ermitteln des Pfades eines geladenen Moduls

Um den Pfad eines geladenen Moduls herauszufinden, kann die Funktion GetLoadedModulePath verwendet werden. In diesem Beispiel wird der Pfad der Shell32.dll ermittelt:

Private Declare Function GetModuleFileName _
    Lib "kernel32.dll" _
    Alias "GetModuleFileNameA" _
( _
    ByVal hModule As Long, _
    ByVal lpFileName As String, _
    ByVal nSize As Long _
) As Long

Private Declare Function GetModuleHandle _
    Lib "kernel32.dll" _
    Alias "GetModuleHandleA" _
( _
    ByVal lpModuleName As String _
) As Long

Private Function GetLoadedModulePath(ByVal FileName As String) As String
    Dim hModule As Long, Path As String, PathLength As Long
    hModule = GetModuleHandle(FileName)
    Path = Space$(255)
    PathLength = GetModuleFileName(hModule, Path, Len(Path))
    GetLoadedModulePath = Left$(Path, PathLength)
End Function

Private Sub Main()
    Call MsgBox(GetLoadedModulePath("shell32.dll"))
End Sub

Abspielen von Windows-Systemklängen

Im Normalfall werden bei der Anzeige von Windows-Meldungsfeldern automatisch auch die zugehörigen Klangdateien abgespielt, die in der Systemsteuerung eingestellt sind. Werden diese Klänge auch bei eigenen Dialogfelder benötigt, brauchen man nicht umständlich die Systemregistrierung bzw. Win.ini auszulesen, denn für diesen Zweck stellt das Windows-API die Funktion MessageBeep zur Verfügung:

Private Declare Function MessageBeep Lib "user32.dll" Alias "MessageBeep" ( _
    ByVal wType As Long _
) As Long

Für wType wird eine der folgenden Konstanten verwendet, die den abzuspielenden Klang darstellt:

Private Const MB_ICONASTERISK As Long = &H40&        ' Information.
Private Const MB_ICONEXCLAMATION As Long = &H30&     ' Ausrufezeichen.
Private Const MB_ICONHAND As Long = &H10&            ' Stopschild.
Private Const MB_ICONQUESTION As Long = &H20&        ' Fragezeichen.
Private Const MB_OK As Long = &H0&                   ' Standard-OK.

Anzeigen von Windows-Systemsymbolen

Um die Symbole, die Windows für die Meldungsfelder verwendet, in einer Anwendung zu benutzen, ist es nicht notwendig, eigene Bitmaps mit diesen Symbolen zu erstellen und zu laden. Die folgende Funktion DrawSystemIcon zeichnet ein entsprechendes Symbol an angegebener Position auf einen Gerätekontext. Der Vorteil liegt darin, daß immer die der verwendeten Windows-Version entsprechenden Symbole geladen werden:

Private Declare Function LoadIconByNum Lib "user32.dll" Alias "LoadIconA" ( _
    ByVal hInstance As Long, _
    ByVal lpIconName As Long _
) As Long

Private Declare Function DrawIcon Lib "user32.dll" ( _
    ByVal hdc As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal hIcon As Long _
) As Long

Private Enum SystemIcons
    IDI_APPLICATION = 32512&
    IDI_ASTERISK = 32516&
    IDI_EXCLAMATION = 32515&
    IDI_HAND = 32513&
    IDI_QUESTION = 32514&
End Enum

Private Sub DrawSystemIcon( _
    ByVal hdc As Long, _
    ByVal IconType As SystemIcons, _
    ByVal Left As Long, _
    ByVal Top As Long _
)
    Dim hIcon As Long
    hIcon = LoadIconByNum(0&, IconType)
    Call DrawIcon(hdc, Left, Top, hIcon)
End Sub

Der Aufruf der Funktion könnte dann beispielsweise in einem Form_Load-Ereignis wie im untenstehenden Code erfolgen (hier wird das Symbol in eine PictureBox gezeichnet):

With Me.Picture1
    .ScaleMode = vbPixels
    .AutoRedraw = True
    
    ' Draw icon.
    Call DrawSystemIcon(.hDC, IDI_APPLICATION, 15&, 10&)
    
    Call .Refresh
    .AutoRedraw = False
End With

Ermitteln von Computer- und Benutzername

Eine etwas einfachere Version als in vorigem Codebeispiel stellt die Funktion GetUserName dar. Es wird auch der Name des Rechners, an dem der Benutzer angemeldet ist, ermittelt:

Private Declare Function GetUserName _
    Lib "advapi32.dll" _
    Alias "GetUserNameA" _
( _
    ByVal lpBuffer As String, _
    ByRef nSize As Long _
) As Long

Private Declare Function GetComputerName _
    Lib "kernel32.dll" _
    Alias "GetComputerNameA" _
( _
    ByVal lpBuffer As String, _
    ByRef nSize As Long _
) As Long

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31&

Private Function UserName() As String
    Dim s As String
    s = Space$(255)
    Dim nSize As Long
    nSize = Len(s)
    Dim n As Long
    n = GetUserNameA(s, nSize)
    If n = 0& Then
        UserName = ""
    Else
        UserName = Left$(s, nSize - 1)
    End If
End Function

Private Function ComputerName() As String
    Dim s As String
    s = Space$(MAX_COMPUTERNAME_LENGTH + 1)
    Dim nSize As Long
    nSize = Len(s)
    Dim n As Long
    n = GetComputerNameA(s, nSize)
    If n = 0& Then
        ComputerName = ""
    Else
        ComputerName = Left$(s, nSize - 1)
    End If
End Function

Private Sub Main()
    Call MsgBox(UserName & " @ " & ComputerName)
End Sub

Prüfen, ob eine Soundkarte vorhanden ist

Folgende Funktion ermittelt, ob im System eine Soundkarte vorhanden ist, oder nicht:

Private Declare Function waveOutGetNumDevs Lib "winmm.dll" ( _
) As Long

Private Function CheckSoundCard() As Boolean
    CheckSoundCard = (waveOutGetNumDevs > 0)
End Function

Private Sub Main()
    Call MsgBox( _
        IIf( _
            CheckSoundCard, _
            "Soundkarte vorhanden.", _
            "Keine Soundkarte vorhanden." _
        ) _
    )
End Sub

Ermitteln aller Drucker und des Standarddruckers

Folgender Code zeigt die Namen aller Drucker und ihren Anschluß sowie den Standarddrucker an:

Dim i As Integer, s As String
For i = 0 To Printers.Count - 1
    s = Printers(i).DeviceName
    s = s & " on " & Printers(i).Port
    If Printer.DeviceName = Printers(i).DeviceName Then
        Debug.Print s & "  (Standarddrucker)"
    Else
        Debug.Print s
    End If
Next i

Prüfen, ob ein Drucker installiert ist

Folgende kleine Funktionsprozedur kann verwendet werden, um zu ermitteln, ob ein Drucker am System installiert ist:

Private Function PrinterInstalled() As Boolean
    On Error Resume Next
    Dim s As String
    s = Printer.DeviceName
    PrinterInstalled = (Err.Number = 0)
End Function

Ermitteln der Beschreibungstexte zu API-Fehlern

Folgender Code zeigt, wie man den Beschreibungstext zu einem Windows-API-Fehler ermitteln kann:

Private Declare Function FormatMessage _
    Lib "kernel32.dll" _
    Alias "FormatMessageA" _
( _
    ByVal dwFlags As Long, _
    ByRef lpSource As Any, _
    ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, _
    ByVal lpBuffer As String, _
    ByVal nSize As Long, _
    ByRef Arguments As Long _
) As Long

Private Declare Function RegOpenKeyEx _
    Lib "advapi32.dll" _
    Alias "RegOpenKeyExA" _
( _
    ByVal hKey As Long, _
    ByVal lpSubKey As String, _
    ByVal ulOptions As Long, _
    ByVal samDesired As Long, _
    ByRef phkResult As Long _
) As Long

Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000&

Private Sub Main()
    Dim Error As Long, n As Long, Buffer As String
    
    ' Hier wird ein Fehler erzeugt, indem ungültige Werte an die Funktion
    ' übergeben werden.
    Error = RegOpenKeyEx(0&, 0&, 0&, 0&, 0&)
    
    ' Fehlerbeschreibung ermitteln.
    Buffer = Space$(256)
    n = FormatMessage( _
        FORMAT_MESSAGE_FROM_SYSTEM, _
        0&, _
        Error, _
        0&, _
        Buffer, _
        Len(Buffer), _
        ByVal 0& _
    )
    
    ' Ausgabe der Fehlerbeschreibung.
    Call MsgBox(Left$(Buffer, n))
End Sub

Ermitteln der Belegung des Arbeitsspeichers

Folgender Code kann verwendet werden, um Informationen über die Arbeitsspeicherbelegung zu ermitteln:

Private Declare Sub GlobalMemoryStatus Lib "kernel32.dll" ( _
    ByRef lpBuffer As MEMORYSTATUS _
)

Private Type MEMORYSTATUS
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
End Type

Private Sub Main()
    Dim ms As MEMORYSTATUS
    Call GlobalMemoryStatus(ms)
    Dim Info As String
    With ms
        Info = _
            CStr(.dwMemoryLoad) & "% des Speichers belegt" & vbNewLine & _
            vbNewLine & _
            "Totaler physischer Speicher:  " & _
            CStr(.dwTotalPhys) & vbNewLine & _
            "Davon noch frei:  " & _
            CStr(.dwAvailPhys) & vbNewLine & _
            vbNewLine & _
            "Bytes in ausgelagerten Dateien:  " & _
            CStr(.dwTotalPageFile) & vbNewLine & _
            "Davon noch frei:  " & _
            CStr(.dwAvailPageFile) & vbNewLine & _
            vbNewLine & _
            "Totaler virtueller Speicher:  " & _
            CStr(.dwTotalVirtual) & vbNewLine & _
            "Davon noch frei:  " & CStr(.dwAvailVirtual)
    End With
    Call MsgBox(Info)
End Sub

Aufzeichnen von Start und Herunterfahren des Betriebssystems

Um den Zeitpunkt, an dem Windows gestartet und heruntergefahren wurde aufzuzeichnen, kann eine kleine Anwendung verwendet werden, die beim Start von Windows automatisch über den Autostart-Ordner geladen wird. Diese läuft während der gesamten Windows-Sitzung und wird von Windows automatisch beendet, wenn der Rechner heruntergefahren wird. Dabei werden die Zeiten in eine Textdatei geschrieben:

Private Sub Form_Load()
    Open "C:\WinLog.txt" For Append As #1
    Print #1, "On: " & CStr(Now)
    Close #1
    Me.Visible = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Open "C:\WinLog.txt" For Append As #1
    Print #1, "Off: " & CStr(Now)
    Close #1
End Sub

Ermitteln des Startmodus von Windows

Über die API-Funktion GetSystemMetrics mit der Konstanten SM_CLEANBOOT als Wert des Parameters nIndex kann ermittelt werden, ob Windows normal, im abgesicherten Modus oder im abgesicherten Modus mit Netzwerk gestartet wurde:

Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long _
) As Long

Private Const SM_CLEANBOOT As Long = 67

Private Sub Main()
    Dim StartOption As String
    Select Case GetSystemMetrics(SM_CLEANBOOT)
        Case 0
            StartOption = "Windows wurde normal gestartet."
        Case 1
            StartOption = "Abgesicherter Modus."
        Case 2
            StartOption = "Abgesicherter Modus mit Netzwerk."
    End Select
    Call MsgBox(StartOption)
End Sub

Ermitteln der Bildschirmauflösung

Folgende Zeile Code gibt die aktuelle Auflösung aus:

Debug.Print _
    CStr(Screen.Width \ Screen.TwipsPerPixelX) & _
    " x " & _
    CStr(Screen.Height \ Screen.TwipsPerPixelY)

Ändert sich jedoch die Auflösung, während das Programm läuft, dann werden falsche Werte zurückgegeben. Eine weitere, sicherere Methode bedient sich dazu des Windows-API:

Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long _
) As Long

Private Const SM_CXSCREEN As Long = 0&
Private Const SM_CYSCREEN As Long = 1&

Private Type ScreenResolution
    Horizontal As Integer
    Vertical As Integer
End Type

Private Sub Main()
    Dim sr As ScreenResolution
    sr = GetScreenResolution()
    Call MsgBox( _
        "Auflösung:  " & _
        CStr(sr.Horizontal) & _
        " x " & _
        CStr(sr.Vertical) _
    )
End Sub

Private Function GetScreenResolution() As ScreenResolution
    With GetScreenResolution
        .Horizontal = GetSystemMetrics(SM_CXSCREEN)
        .Vertical = GetSystemMetrics(SM_CYSCREEN)
    End With
End Sub

Minimieren aller Fenster

Um alle Fenster zu minimieren, kann die Tastenkombination Win+F4 gedrückt werden. Die selbe Funktionalität kann auch im Code durch die Prozedur MinimizeAll erzielt werden:

Private Declare Sub keybd_event Lib "user32.dll" ( _
    ByVal bVk As Byte, _
    ByVal bScan As Byte, _
    ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long _
)

Private Const KEYEVENTF_KEYUP As Long = &H2&
Private Const VK_LWIN As Long = &H5B&

Private Sub MinimizeAll()
    Call keybd_event(VK_LWIN, 0&, 0&, 0&)
    Call keybd_event(77&, 0&, 0&, 0&)
    Call keybd_event(VK_LWIN, 0&, KEYEVENTF_KEYUP, 0&)
End Sub

Prüfen, ob eine Schriftart installiert ist

Wenn man ausgefallene Schriftarten verwendet, ist es oft ratsam, zu prüfen, ob sie auch auf dem Zielrechner installiert sind. Dazu kann die folgende Funktion verwendet werden:

Private Function IsFontInstalled(ByVal FontName As String) As Boolean
    Dim sfn As New StdFont
    sfn.Name = FontName
    IsFontInstalled = (StrComp(FontName, sfn.Name, vbTextCompare) = 0)
End Function

Private Sub Main()
    Dim s As String, t As String
    s = "Arial"
    t = s & ": " & IsFontInstalled(s) & vbNewLine
    s = "Quake"
    t = t & s & ": " & IsFontInstalled(s)
    Call MsgBox(t)
End Sub

Unterscheiden zwischen kleinen oder großen Schriftarten

Benutzer haben die Möglichkeit, zwischen kleinen und großen Schriften zu wählen. Die im Folgenden angegebene Funktion kann verwendet werden, um zwischen diesen beiden Einstellungen zu unterscheiden:

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

Private Declare Function GetDC Lib "user32.dll" ( _
    ByVal hWnd As Long _
) As Long

Private Declare Function GetDeviceCaps Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal nIndex As Long _
) As Long

Private Declare Function ReleaseDC Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByVal hdc As Long _
) As Long

Private Function SmallFonts() As Boolean
    Dim hWndDesktop As Long, hDCDesktop As Long
    Dim PixelsX As Long
    hWndDesktop = GetDesktopWindow
    hDCDesktop = GetDC(hWndDesktop)
    PixelsX = GetDeviceCaps(hDCDesktop, 88)
    Call ReleaseDC(hWndDesktop, hDCDesktop)
    SmallFonts = (PixelsX = 96)
End Function

Private Sub Main()
    Call MsgBox( _
        "Es werden " & _
        IIf(SmallFonts, "kleine", "große") & _
        " Schriftarten verwendet." _
    )
End Sub

Eine weitere, etwas andere Möglichkeit bietet der folgende Code:

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

Private Declare Function GetWindowDC Lib "user32.dll" ( _
    ByVal hWnd As Long _
) As Long

Private Declare Function ReleaseDC Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByVal hdc As Long _
) As Long

Private Declare Function GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" ( _
    ByVal hdc As Long, _
    ByRef lpMetrics As TEXTMETRIC _
) As Long

Private Declare Function SetMapMode Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal nMapMode As Long _
) As Long

Private Const MM_TEXT As Long = 1&

Private Type TEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet As Byte
End Type

Public Function LargeFonts() As Boolean
    Dim hdc As Long, hWnd As Long, PrevMapMode As Long
    Dim tm As TEXTMETRIC
    
    ' Get the handle of the desktop window.
    hWnd = GetDesktopWindow()
    
    ' Get the device context for the desktop.
    hdc = GetWindowDC(hWnd)
    
    If hdc Then
        
        ' Set the mapping mode to pixels.
        PrevMapMode = SetMapMode(hdc, MM_TEXT)
        
        ' Get the size of the system font.
        Call GetTextMetrics(hdc, tm)
        
        ' Set the mapping mode back to what it was.
        Call SetMapMode(hdc, PrevMapMode)
        
        ' Release the device context.
        Call ReleaseDC(hWnd, hdc)
        
        ' If the system font is more than 16 pixels high, then large fonts are
        ' being used.
        LargeFonts = (tm.tmHeight > 16)
    End If
End Function

Private Sub Main()
    Call MsgBox("Large Fonts:  " & LargeFonts)
End Sub

Aktivieren des Bildschirmschoners

Über den nächsten Code kann unter Windows 95 und seinen Nachfolgeversionen der Bildschirmschoner aktiviert werden. Leider besteht diese Möglichkeit nicht mehr unter Windows 2000 und dessen Nachfolgeversionen:

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long _
) As Long

Private Const WM_SYSCOMMAND As Long = &H112&

Private Const SC_SCREENSAVE As Long = &HF140&

Private Sub ActivateScreenSaver()
    
    ' Bildschirmschoner aktivieren. Funktioniert nicht unter Windows NT und
    ' seinen Nachfolgeversionen.
    Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
End Sub

Ermitteln der Systemsprache

Die Systemsprache wird ermittelt:

Private Declare Function GetSystemDefaultLangID Lib "kernel32.dll" ( _
) As Integer

Private Declare Function VerLanguageName _
    Lib "kernel32.dll" _
    Alias "VerLanguageNameA" _
( _
    ByVal wLang As Long, _
    ByVal szLang As String, _
    ByVal nSize As Long _
) As Long

Private Sub Main()
    Call MsgBox("The system default language is " & GetSystemLanguage & ".")
End Sub

Private Function GetSystemLanguage() As String
    Dim Language As String, LanguageID As Integer, n As Long
    Language = Space$(64)
    LanguageID = GetSystemDefaultLangID ' LanguageID holds the language ID.
    n = VerLanguageName(LanguageID, Language, Len(Language))
    GetSystemLanguage = Left$(Language, n)
End Function

Starten des Assistenten zum Erstellen einer Verknüpfung

Der Assistent zum Erstellen von Verknüpfungen kann über folgenden Code gestartet werden:

Call Shell( _
    "rundll32.exe AppWiz.cpl,NewLinkHere " & App.Path & "\", _
    vbNormalFocus _
)

Prüfen, ob der Active Desktop aktiviert ist

Folgender Code ermittelt, ob der Active Desktop aktiviert ist:

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String _
) As Long

Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" ( _
    ByVal hWndParent As Long, _
    ByVal hWndChildAfter As Long, _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String _
) As Long

Private Sub Main()
    Call MsgBox("Active Desktop: " & IE4ActiveDesktop)
End Sub

Private Function IE4ActiveDesktop() As Boolean
    Dim n As Long
    n = FindWindow("Progman", vbNullString)
    n = FindWindowEx(n, 0&, "SHELLDLL_DefView", vbNullString)
    n = FindWindowEx(n, 0&, "Internet Explorer_Server", vbNullString)
    IE4ActiveDesktop = (n > 0)
End Function

Kopieren von Text in die Zwischenablage mittels API-Aufrufen

Folgender Code zeigt, wie man über Verwendung von API-Funktionen Text in der Zwischenablage plazieren kann:

Private Declare Function OpenClipboard Lib "user32.dll" ( _
    ByVal hwnd As Long _
) As Long

Private Declare Function CloseClipboard Lib "user32.dll" ( _
) As Long

Private Declare Function EmptyClipboard Lib "user32.dll" ( _
) As Long

Private Declare Function SetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Long, _
    ByVal hMem As Long _
) As Long

Private Declare Function GetClipboardOwner Lib "user32.dll" ( _
) As Long

Private Const CF_TEXT As Long = 1&

Private Declare Function GlobalAlloc Lib "kernel32.dll" ( _
    ByVal wFlags As Long, _
    ByVal dwBytes As Long _
) As Long

Private Declare Function GlobalLock Lib "kernel32.dll" ( _
    ByVal hMem As Long _
) As Long

Private Declare Function GlobalUnlock Lib "kernel32.dll" ( _
    ByVal hMem As Long _
) As Long

Private Declare Function GlobalFree Lib "kernel32.dll" ( _
    ByVal hMem As Long _
) As Long

Private Const GMEM_MOVEABLE As Long = &H2&

Private Declare Function lstrcpy Lib "kernel32" ( _
    ByVal lpStr1 As Any, _
    ByVal lpStr2 As Any _
) As Long

Private Sub Main()
    
    ' Beispieltext ins Clipboard setzen.
    Call Clipboard.Clear
    Call Clipboard.SetText("Visual Basic")
    
    ' Neuer Text für das Clipboard.
    Dim s As String
    s = "Hallo Welt!"
    
    ' Text per API in das Clipboard kopieren.
    Dim hMem As Long
    Dim hAdr As Long
    hMem = GlobalAlloc(GMEM_MOVEABLE, Len(s) + 1)
    hAdr = GlobalLock(hMem)
    Call lstrcpy(hAdr, s)
    Call GlobalUnlock(hMem)
    
    Call OpenClipboard(0&)
    Call EmptyClipboard
    If SetClipboardData(CF_TEXT, hMem) = 0 Then
        Call MsgBox("Fehler beim Setzen der Daten in die Zwischenablage!")
        Call GlobalFree(hMem)
    End If
    Call CloseClipboard
    
    ' Text aus Clipboard holen.
    Call MsgBox(Clipboard.GetText)
End Sub

Dabei ist zu beachten, daß GlobalUnlock vor dem Aufruf von CloseClipboard aufgerufen werden muß. Außerdem muß hMem nur dann mit GlobalFree freigegeben werden, wenn die Daten nicht in der Zwischenablage abgelegt werden konnten, sonst übernimmt Windows diese Aufgabe.

Starten und zeitgesteuertes Beenden von Programmen

Folgender Code startet eine Anwendung, in diesem Beispiel den Editor, und wartet zwei Sekunden, ob die Anwendung beendet wird. Schließt der Benutzer in der Zwischenzeit die Anwendung, dann wird eine entsprechende Meldung ausgegeben, andernfalls wird versucht, die Anwendung zu beenden. Dies funktioniert nicht unter Windows 2000 und seinen Nachfolgeversionen:

Private Declare Function WaitForSingleObject Lib "kernel32.dll" ( _
    ByVal hHandle As Long, _
    ByVal dwMilliseconds As Long _
) As Long

Private Declare Function CloseHandle Lib "kernel32.dll" ( _
    ByVal hObject As Long _
) As Long

Private Declare Function OpenProcess Lib "kernel32.dll" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long _
) As Long

Private Declare Function TerminateProcess Lib "kernel32.dll" ( _
    ByVal hProcess As Long, _
    ByVal uExitCode As Long _
) As Long

Private Const INFINITE As Long = -1&
Private Const SYNCHRONIZE As Long = &H100000

Private Sub Main()
    
    ' Starten der Anwendung
    On Error Resume Next
    Dim pid As Long
    pid = Shell("notepad.exe", vbNormalFocus)
    If Err.Number <> 0 Then
        Call MsgBox( _
            "Error " & Err.Number & ": " & Err.Description & ".", _
            vbExclamation, _
            App.Title _
        )
        Call Err.Clear
    End If
    On Error GoTo 0
    
    ' Zugriff auf Projekt
    Dim hProcess As Long
    hProcess = OpenProcess(SYNCHRONIZE, 0&, pid)
    If WaitForSingleObject(hProcess, 2000&) Then
        
        ' Dies funktioniert nicht unter Windows 2000/XP.
        Call TerminateProcess(hProcess, 0&)
        Call CloseHandle(hProcess)
        Call MsgBox("Durch das Programm geschlossen.")
    Else
        Call MsgBox("Durch den Anwender geschlossen.")
    End If
End Sub

Anzeigen des Dialogs zur Konfiguration von Druckeranschlüssen

Die API-Funktion ConfigurePort dient dazu, den Dialog zur Konfiguration eines Druckerports anzuzeigen. Das Ermitteln der im Netzwerk verfügbaren Portnamen kann über die API-Funktion EnumPorts durchgeführt werden:

Private Declare Function ConfigurePort Lib "winspool.drv" _
    Alias "ConfigurePortA" ( _
    ByVal pName As String, _
    ByVal hWnd As Long, _
    ByVal pPortName As String _
) As Long

Private Sub cmdConfigCOM_Click()
    
    ' Anstelle von "COM4" kann auch "LPT1" etc. angegeben werden.
    ' Am Besten ist es, die Namen der Anschlüsse über die API-Funktion
    ' 'EnumPorts' zu ermitteln.
    Dim n As Long
    n = ConfigurePort("", Me.hWnd, "COM4")
    If n = 0 Then
        Debug.Print "Error."
    ElseIf n = 1 Then
        Debug.Print "Success."
    End If
End Sub

Anordnen der Symbole auf dem Desktop

Die Prozedur ArrangeDesktopIcons veranlaßt, daß die Symbole am Windows-Desktop entsprechend der im Parameter getroffenen Einstellung neu anordnet:

Private Declare Function GetWindow Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByVal wCmd As Long _
) As Long

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long _
) As Long

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String _
) As Long

Private Const GW_CHILD As Long = 5&

Private Enum ItemArrangements
    LVA_ALIGNLEFT = &H1&
    LVA_ALIGNTOP = &H2&
    LVA_DEFAULT = &H0&
    LVA_SNAPTOGRID = &H5&
End Enum

Private Const LVM_ARRANGE As Long = &H1016&

Private Sub ArrangeDesktopIcons(ByVal Arrangement As ItemArrangements)
    Dim hWnd1 As Long, hWnd2 As Long
    hWnd1 = FindWindow("Progman", vbNullString)
    hWnd2 = GetWindow(hWnd1, GW_CHILD)
    hWnd1 = GetWindow(hWnd2, GW_CHILD)
    Call SendMessage(hWnd1, LVM_ARRANGE, Arrangement, 0&)
End Sub

Überwachen des Desktops auf Fokuserhalt

Um zu Überwachen, wann der Desktop den Fokus erhält, kann man sich der im Folgenden präsentierten einfachen Vorgehensweise bedienen. Dazu benötigt man ein Timer-Steuerelement, das alle n Millisekunden prüft, ob das Fenster mit dem Fokus gleich der Desktop ist:

Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

Private Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" ( _
    ByVal hWnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long _
) As Long

Private Sub Form_Load()
    Me.Timer1.Interval = 100
    Me.Timer1.Enabled = True
    Call Timer1_Timer
End Sub

Private Sub Timer1_Timer()
    Dim ClassName As String
    ClassName = String$(255, vbNullChar)
    Dim n As Long, hWndActive As Long
    hWndActive = GetForegroundWindow
    n = GetClassName(hWndActive, ClassName, Len(ClassName))
    If n <> 0 Then
        Select Case Left$(ClassName, n)
            Case "Progman", "WorkerW"
                Call MsgBox("Der Desktop ist das aktive Fenster!")
        End Select
    End If
End Sub

Ermitteln von Position und Größe der Taskleiste

Folgender Code ermittelt die Position der Taskleiste:

Private Declare Function SHAppBarMessage Lib "shell32.dll" ( _
    ByVal dwMessage As Long, _
    ByRef pData As APPBARDATA _
) As Long

Private Const ABM_GETTASKBARPOS As Long = &H5&

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type APPBARDATA
    cbSize As Long
    hwnd As Long
    uCallbackMessage As Long
    uEdge As Long
    rc As RECT
    lParam As Long
End Type

Private Sub Main()
    Dim TaskBarPos As APPBARDATA
    Call SHAppBarMessage(ABM_GETTASKBARPOS, TaskBarPos)
    With TaskBarPos.rc
        Call MsgBox( _
            "Left:  " & CStr(.Left) & vbNewLine & _
            "Top:  " & CStr(.Top) & vbNewLine & _
            "Right:  " & CStr(.Right) & vbNewLine & _
            "Bottom:  " & CStr(.Bottom) _
        )
    End With
End Sub

Auflisten der Dateinamen aller ausgeführten Prozesse

Folgender Code gibt die Namen der zu den gerade laufenden Prozessen gehörenden Module, also die Dateinamen aus:

Private Declare Function CloseHandle Lib "kernel32.dll" ( _
    ByVal hObject As Long _
) As Long

Private Declare Function CreateToolhelp32Snapshot Lib "kernel32.dll" ( _
    ByVal dwFlags As Long, _
    ByVal th32ProcessID As Long _
) As Long

Private Declare Function Process32First Lib "kernel32.dll" ( _
    ByVal hSnapshot As Long, _
    ByRef lppe As Any _
) As Long

Private Declare Function Process32Next Lib "kernel32.dll" ( _
    ByVal hSnapshot As Long, _
    ByRef lppe As Any _
) As Long

Private Const MAX_PATH As Long = 260&

Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * MAX_PATH
End Type

Private Const TH32CS_SNAPHEAPLIST As Long = &H1&
Private Const TH32CS_SNAPPROCESS As Long = &H2&
Private Const TH32CS_SNAPTHREAD As Long = &H4&
Private Const TH32CS_SNAPMODULE As Long = &H8&
Private Const TH32CS_INHERIT As Long = &H80000000
Private Const TH32CS_SNAPALL As Long = _
    TH32CS_SNAPHEAPLIST Or _
    TH32CS_SNAPPROCESS Or _
    TH32CS_SNAPTHREAD Or _
    TH32CS_SNAPMODULE

Private Sub Main()
    Dim hSnapshot As Long, n As Long, P As PROCESSENTRY32
    P.dwSize = Len(P)
    hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, ByVal 0&)
    If hSnapshot <> 0& Then
        n = Process32First(hSnapshot, P)
        Do While n <> 0&
            Debug.Print Left$(P.szExeFile, InStr(P.szExeFile, vbNullChar) - 1)
            n = Process32Next(hSnapshot, P)
        Loop
        n = CloseHandle(hSnapshot)
    End If
End Sub

Ermitteln von Windows- und Systemverzeichnis

Die API-Funktion GetWindowsDirectory kann verwendet werden, um den Pfad des Windows-Verzeichnisses zu ermitteln:

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

Private Const MAX_PATH As Long = 260&

Private Sub Main()
    Call MsgBox( _
        "Windows-Verzeichnis:" & vbNewLine & _
        GetWinDir _
    )
End Sub

Private Function GetWinDir() As String
    Dim Buffer As String
    Buffer = Space$(MAX_PATH)
    Dim uSize As Long
    uSize = GetWindowsDirectory(Buffer, Len(Buffer))
    GetWinDir = Left$(Buffer, uSize)
End Function

Analog kann auch das Systemverzeichnis ermittelt werden, wobei hier die API-Funktion GetSystemDirectory zum Einsatz gelangt:

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

Private Sub Main()
    Call MsgBox( _
        "Windows-Systemverzeichnis:" & vbNewLine & _
        GetWinSysDir _
    )
End Sub

Private Function GetWinSysDir() As String
    Dim Buffer As String
    Buffer = Space$(MAX_PATH)
    Dim uSize As Long
    uSize = GetSystemDirectory(Buffer, Len(Buffer))
    GetWinSysDir = Left$(Buffer, uSize)
End Function

Prüfen, ob eine Verbindung ins Internet besteht

Mit dem folgenden Code kann ermittelt werden, ob eine Verbindung in das Internet besteht:

Private Declare Function RasEnumConnections _
    Lib "rasapi32.dll" _
    Alias "RasEnumConnectionsA" _
( _
    ByRef lpRasCon As Any, _
    ByRef lpcb As Long, _
    ByRef lpcConnections As Long _
) As Long

Private Declare Function RasGetConnectStatus _
    Lib "rasapi32.dll" _
    Alias "RasGetConnectStatusA" _
( _
    ByVal hRasCon As Long, _
    ByRef lpStatus As Any _
) As Long

Private Const RAS95_MaxEntryName As Long = 256&
Private Const RAS95_MaxDeviceType As Long = 16&
Private Const RAS95_MaxDeviceName As Long = 32&

Private Type RASCONN95
    dwSize As Long
    hRasCon As Long
    szEntryName(RAS95_MaxEntryName) As Byte
    szDeviceType(RAS95_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Private Type RASCONNSTATUS95
    dwSize As Long
    RasConnState As Long
    dwError As Long
    szDeviceType(RAS95_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Private Function IsConnected() As Boolean
    Dim rcRasCon(255) As RASCONN95
    Dim g As Long, pCon As Long, n As Long
    Dim rcsStatus As RASCONNSTATUS95
    rcRasCon(0).dwSize = 412
    g = 256 * rcRasCon(0).dwSize
    n = RasEnumConnections(rcRasCon(0), g, pCon)
    If n <> 0& Then
        Call Err.Raise( _
            vbObjectError + 1, _
            "Error getting connection status." _
        )
        Exit Function
    End If
    rcsStatus.dwSize = 160
    n = RasGetConnectStatus(rcRasCon(0).hRasCon, rcsStatus)
    IsConnected = (rcsStatus.RasConnState = &H2000&)
End Function

Private Sub Main()
    If IsConnected Then
        Call MsgBox("You are online.")
    Else
        Call MsgBox("You are offline.")
    End If
End Sub