VBA Klasse: Standardeingabe und Standardausgabe in Konsole bereitstellen

Aus DBWiki
Wechseln zu: Navigation, Suche

Problem

Weil das Direktfenster nur Zeichen, die dem eingestellten Gebietsschema für Unicode-inkompatible Programme entspricht, darstellt, soll ein Konsolefenster geöffnet werden, das alle Unicode-Zeichen, sofern sie von der eingestellten Schriftart unterstützt werden, ausgeben kann.

Lösung

Für jedes Windows-Programm lässt sich auch eine Konsole öffnen, die sich wie die Eingabeaufforderung darstellt. Darin kann man den Standardeingabe- und Standardausgabe-Stream, der zuvor über das FileSystemObject besorgt wurde, bereitgestellen, und zur Texteingabe und Textausgabe benutzen. Folgender Code ist dazu in einem neuen Klassenmodul zu verwenden. Ich verwende die Klasse unter dem Namen Console - aber auch jeder andere Klassenname ist denkbar. Schriftart, Höhe, Breite, Farben, etc. lassen sich über das Systemmenü Eigenschaften des Konsolefensters anpassen und dauerhaft speichern.

Option Explicit
 
Private Const SC_CLOSE     As Long = &HF060
Private Const MF_BYCOMMAND As Long = &H0
 
#If VBA7 Then
Private Declare PtrSafe Function AllocConsole Lib "kernel32" () As Long
Private Declare PtrSafe Function FreeConsole Lib "kernel32" () As Long
Private Declare PtrSafe Function GetConsoleWindow Lib "kernel32" () As LongPtr
Private Declare PtrSafe Function GetSystemMenu Lib "user32" ( _
   ByVal hwnd As LongPtr, ByVal bRevert As Long) As LongPtr
Private Declare PtrSafe Function DeleteMenu Lib "user32" ( _
   ByVal hMenu As LongPtr, ByVal nPosition As Long, _
   ByVal wFlags As Long) As Long
Private Declare PtrSafe Function SetConsoleTitleA Lib "kernel32" ( _
   ByVal lpConsoleTitle As String) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" ( _
   ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetConsoleOutputCP Lib "kernel32" () As Long
Private Declare PtrSafe Function SetConsoleOutputCP Lib "kernel32" ( _
   ByVal wCodePageID As Long) As Long
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" ( _
   ByVal hwnd As LongPtr) As Long
#Else
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetConsoleWindow Lib "KERNEL32.DLL" () As Long
Private Declare Function GetSystemMenu Lib "user32" ( _
   ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" ( _
   ByVal hMenu As Long, ByVal nPosition As Long, _
   ByVal wFlags As Long) As Long
Private Declare Function SetConsoleTitleA Lib "kernel32" ( _
   ByVal lpConsoleTitle As String) As Long
Private Declare Function DrawMenuBar Lib "user32" ( _
   ByVal hwnd As Long) As Long
Private Declare Function GetConsoleOutputCP Lib "kernel32" () As Long
Private Declare Function SetConsoleOutputCP Lib "kernel32" ( _
   ByVal wCodePageID As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" ( _
   ByVal hwnd As Long) As Long
#End If
 
Private mConsoleIn  As Object 'Scripting.TextStream
Private mConsoleOut As Object 'Scripting.TextStream
 
Private Sub Class_Initialize()
   Const StdIn  As Long = 0
   Const StdOut As Long = 1
 
   #If VBA7 Then
      Dim hWndCon As LongPtr
      Dim hMenuHandle As Long
   #Else
      Dim hWndCon As Long
      Dim hMenuHandle As Long
   #End If
 
   Call AllocConsole
 
   ' Schließen der Konsole über den Schließknopf bzw. das Systemmenü
   ' verhindern  - sonst würde Access auch geschlossen werden
   hWndCon = GetConsoleWindow()
   hMenuHandle = GetSystemMenu(hWndCon, 0)
   Call DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND)
   Call SetConsoleTitleA(Application.Name & ": " & CurrentProject.Name)
   Call DrawMenuBar(GetConsoleWindow())
   'Unicode-Ausgabe verwenden
   Call SetConsoleOutputCP(1200)
   Call SetForegroundWindow(hWndCon)
 
   With CreateObject("Scripting.FileSystemObject")
      Set mConsoleIn = .GetStandardStream(StdIn, True)
      Set mConsoleOut = .GetStandardStream(StdOut, True)
   End With
End Sub
 
Private Sub Class_Terminate()
   Call FreeConsole
End Sub
 
Public Sub ConWrite(Text As String)
   mConsoleOut.Write Text
End Sub
 
Public Sub WriteLn(Text As String)
   mConsoleOut.WriteLine Text
End Sub
 
Public Sub WriteBlankLines(Lines As Long)
   mConsoleOut.WriteBlankLines Lines
End Sub
 
Public Function ConRead(Characters As Long) As String
   ConRead = mConsoleIn.Read(Characters)
End Function
 
Public Function ReadLn() As String
   ReadLn = mConsoleIn.ReadLine()
End Function

Aufruf

Public Sub TestConsole()
   Dim v As Variant
   Dim s As String
   Dim i As Long
 
   v = Array(&H417, &H434, &H440, &H430, &H432, &H441, &H442, &H432, _
             &H443, &H439, &H2C, &H20, &H43C, &H438, &H440, &H21)
   s = Space$(UBound(v) + 1)
   For i = 0 To UBound(v): Mid$(s, i + 1) = ChrW$(v(i)): Next
 
   With New Console
      .WriteLn s
      .WriteBlankLines 1
      .ConWrite "Bitte die Eingabetaste drücken:"
      .ConRead 1
   End With
End Sub
Ausgabe des Beispiels in der Konsole