Tvorba uživatelského DOS okna

Postup:
Založte v projektu novou třídu, nazvanou clsDOS a do ní zapište:
Option Explicit

Public Enum eConsoleState
   ENABLE_LINE_INPUT = &H2
   ENABLE_ECHO_INPUT = &H4
   ENABLE_PROCESSED_INPUT = &H1
   ENABLE_WINDOW_INPUT = &H8
   ENABLE_MOUSE_INPUT = &H10
End Enum

'API a proměnné pro konzoli
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" _
   (ByVal hObject As Long) As Long
Private Declare Function GetStdHandle Lib "kernel32" _
   (ByVal nStdHandle As Long) As Long
Private Declare Function WriteConsole Lib "kernel32" Alias _
   "WriteConsoleA" (ByVal lhwndConsoleOutput As Long, _
   lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, _
   lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
Private Declare Function ReadConsole Lib "kernel32" Alias _
   "ReadConsoleA" (ByVal lhwndhConsoleInput As Long, _
   sBuffer As Any, ByVal nNumberOfCharsToRead As Long, _
   lpNumberOfCharsRead As Long, lpReserved As Any) As Long
Private Declare Function GetConsoleTitle Lib "kernel32" Alias _
   "GetConsoleTitleA" (ByVal lpConsoleTitle As String, _
   ByVal nSize As Long) As Long
Private Declare Function SetConsoleTitle Lib "kernel32" Alias  _
   "GetConsoleTitleA" (ByVal sConsoleTitle As String) As Long
Private Declare Function ReadFile Lib "kernel32" _
   (ByVal hFile As Long, ByVal lpBuffer As String, _
   ByVal nNumberOfBytesToRead As Long, _
   lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function SetForegroundWindow Lib "user32" _
   (ByVal hwnd As Long) As Long
Private Declare Function GetConsoleMode Lib "kernel32" _
   (ByVal lhwndConsole As Long, lpMode As Long) As Long
Private Declare Function SetConsoleMode Lib "kernel32" _
   (ByVal lhwndConsole As Long, lpMode As Long) As Long

'DOS proměnné
Private zlhwndOutput As Long
Private zlhwndInput As Long
Private zlhwndError As Long
Private zlhwndConsole As Long
Private zsCaption As String

'Window API
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 FindWindowA Lib "user32" _
   (ByVal lpClassName As String, _
   ByVal lpWindowName As String) As Long
Private Declare Function DrawMenuBar Lib "user32" _
   (ByVal hwnd As Long) As Long


Function Initialise(Optional bDisableTerminate As _
   Boolean = True) As Boolean

   Const STD_OUTPUT_HANDLE = -11&
   Const STD_INPUT_HANDLE = -10&
   Const STD_ERROR_HANDLE = -12&
   Const clMaxLen As Long = 255
   Dim lRet As Long
   Dim sBuffer As String * clMaxLen

   If zlhwndOutput Then
      'Zavření existující konzole
      Terminate
   End If

   If AllocConsole Then
      zlhwndOutput = GetStdHandle(STD_OUTPUT_HANDLE)
      zlhwndInput = GetStdHandle(STD_INPUT_HANDLE)
      zlhwndError = GetStdHandle(STD_ERROR_HANDLE)
      If zlhwndOutput = 0 Then
         'Nelze alokovat STDOUT
         Initialise = False
      Else
         'Úspěšné otevřené DOS okna
         Initialise = True
         lRet = GetConsoleTitle(sBuffer, clMaxLen)
         If lRet Then
            zsCaption = Left$(sBuffer, lRet)
            zlhwndConsole = FindWindowA("ConsoleWindowClass", zsCaption)
         Else
            zsCaption = ""
         End If

         If bDisableTerminate Then
            'Znemožnění zavření DOS okna uživatelem
            zDialogDisableX "", zlhwndConsole
         End If
      End If
   Else
      'Nepovedlo se alokovat konzoli
      Initialise = False
   End If

End Function

Function Terminate() As Boolean

   If zlhwndOutput Then
      Terminate = CBool(CloseHandle(zlhwndOutput))
      FreeConsole
      zlhwndOutput = 0
      zlhwndConsole = 0
   End If

End Function

Function WriteOutput(ByVal sText As String, _
   Optional bAddLineFeed As Boolean = True) As Boolean

   Dim lNumWritten As Long

   If zlhwndOutput Then
      If bAddLineFeed Then
         sText = sText & vbCrLf
      End If
      WriteOutput = WriteConsole(zlhwndOutput, _
         ByVal sText, Len(sText), lNumWritten, ByVal 0&)
   End If

End Function

Function ReadUserInput(Optional ByVal lNumChars _
   As Long = -1) As String

   Const clMaxChars As Long = 255
   Dim lNumReads As Long, sBuffer As String, lSuccess As Long
   Dim lNumCharsToRead As Long, lNumCharsRead As Long

   If zlhwndOutput Then
      'Přehození okna konzole do popředí
      SetForegroundWindow zlhwndConsole

      'vytvoření buferu pro čtení z konzole
      lNumCharsToRead = clMaxChars
      sBuffer = String(clMaxChars, 0)

      Do
         lNumReads = lNumReads + 1
         lSuccess = ReadConsole(zlhwndInput, ByVal sBuffer, _
            clMaxChars, lNumCharsRead, 0&)
         If lSuccess = 0 Or lNumCharsRead < clMaxChars Or _
               Right$(sBuffer, 2) = vbNewLine Then
            ReadUserInput = ReadUserInput & Left$(sBuffer, lNumCharsRead)
            Exit Do
         End If
         'uložení buferu
         ReadUserInput = ReadUserInput & sBuffer
      Loop
   End If

End Function


Private Function zDialogDisableX(sDialogCaption As String, _
      Optional lHandle As Long) As Boolean

   Const clXIndex As Long = 6
   Const MfByPosition As Long = &H400

   If lHandle <> 0 Then
      zDialogDisableX = DeleteMenu(GetSystemMenu(lHandle, False),_
          clXIndex, MfByPosition)
      Call DrawMenuBar(lHandle)
   End If

End Function

Private Sub Class_Terminate()

   Terminate

End Sub


Property Get Caption() As String

   Caption = zsCaption

End Property

Property Let Caption(Value As String)

   If SetConsoleTitle(Value) Then
      zsCaption = Value
   End If

End Property

Property Get WindowHandle() As Long

   WindowHandle = zlhwndConsole

End Property


Sub Shell(sCommandLine)

   VBA.Shell sCommandLine

End Sub


Property Get ConsoleInputMode() As eConsoleState

   Dim lMode As Long
   Call GetConsoleMode(zlhwndInput, lMode)
   ConsoleInputMode = lMode

End Property

Property Let ConsoleInputMode(Value As eConsoleState)

   Dim lMode As Long
   lMode = Value
   Call SetConsoleMode(zlhwndInput, lMode)

End Property


Příklad použití:
Private Sub Test()

   Set oDOS = New clsDOS
   oDOS.Initialise True
   oDOS.WriteOutput "Zadejte Vaše jméno:"
   Debug.Print oDOS.ReadUserInput
   oDOS.Shell "C:\test.bat"
   oDOS.Terminate

End Sub

Zpět