VB and VBA Users Source Code: Creating a custom DOS window (or console)
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Creating a custom DOS window (or console)
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Wednesday, April 04, 2001
Hits:
1861
Category:
Windows Forms/GUI/Controls/Graphics
Article:
The following code demonstrates some basic functionality for creating and manipulating DOS or Console windows. To use the demonstration code at the bottom of this post, add the class code to a class called clsDOS. Typically, this class will be used when an error occurs which requires interaction with the user. For example, a GUI process can create a console when an error occurs that prevents it from using its normal graphical interface or it may be a free threaded process (which can't show any VB GUI), or a console process that does not normally interact with the user. '----------CLASS MODULE CODE---------- Option Explicit Public Enum eConsoleState ENABLE_LINE_INPUT = &H2 'The ReadFile or ReadConsole function returns only when a carriage return character is read. If this mode is disabled, the functions return when one or more characters are available. ENABLE_ECHO_INPUT = &H4 'Characters read by the ReadFile or ReadConsole function are written to the active screen buffer as they are read. This mode can be used only if the ENABLE_LINE_INPUT mode is also enabled. ENABLE_PROCESSED_INPUT = &H1 'CTRL+C is processed by the system and is not placed in the input buffer. If the input buffer is being read by ReadFile or ReadConsole, other control keys are processed by the system and are not returned in the ReadFile or ReadConsole buffer. If the ENABLE_LINE_INPUT mode is also enabled, backspace, carriage return, and linefeed characters are handled by the system. ENABLE_WINDOW_INPUT = &H8 'User interactions that change the size of the console screen buffer are reported in the console's input buffer. Information about these events can be read from the input buffer by applications using the ReadConsoleInput function, but not by those using ReadFile or ReadConsole. ENABLE_MOUSE_INPUT = &H10 'If the mouse pointer is within the borders of the console window and the window has the keyboard focus, mouse events generated by mouse movement and button presses are placed in the input buffer. These events are discarded by ReadFile or ReadConsole, even when this mode is enabled. End Enum 'Console API and variables 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 Variables Private zlhwndOutput As Long, zlhwndInput As Long, zlhwndError As Long, zlhwndConsole As Long, zsCaption As String 'Window APIs 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 'Purpose : Creates a DOS Console window 'Inputs : N/A 'Outputs : Returns True if successful 'Author : Andrew Baker 'Date : 15/01/2001 11:55 'Notes : The process that calls AllocConsole must not be attached to an existing console ' ie. only one console can be used per process. 'Revisions : 'Assumptions : Function Initialise(Optional bDisableTerminate As Boolean = True) As Boolean Const STD_OUTPUT_HANDLE = -11&, STD_INPUT_HANDLE = -10&, STD_ERROR_HANDLE = -12& Const clMaxLen As Long = 255 Dim lRet As Long Dim sBuffer As String * clMaxLen If zlhwndOutput Then 'Close existing console 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 'Failed to allocate STDOUT Initialise = False Else 'Succeeded in opening DOS window Initialise = True lRet = GetConsoleTitle(sBuffer, clMaxLen) If lRet Then zsCaption = Left$(sBuffer, lRet) zlhwndConsole = FindWindowA("ConsoleWindowClass", zsCaption) Else zsCaption = "" End If If bDisableTerminate Then 'Prevent the user from closing the DOS window 'as it is inprocess and will close this app. zDialogDisableX "", zlhwndConsole End If End If Else 'Failed to allocate console Initialise = False End If End Function 'Purpose : Terminates the active DOS Console window 'Inputs : N/A 'Outputs : Returns True if terminated window 'Author : Andrew Baker 'Date : 15/01/2001 11:55 'Notes : 'Revisions : 'Assumptions : Function Terminate() As Boolean If zlhwndOutput Then Terminate = CBool(CloseHandle(zlhwndOutput)) FreeConsole zlhwndOutput = 0 zlhwndConsole = 0 End If End Function 'Purpose : Writes a string to the console screen buffer beginning at the current cursor location. 'Inputs : sText The text to output to the console 'Outputs : Returns True if terminated window 'Author : Andrew Baker 'Date : 15/01/2001 11:55 'Notes : 'Revisions : 'Assumptions : Function WriteOutput(ByVal sText As String, Optional bAddLineFeed As Boolean = True) As Boolean Dim lNumWritten As Long If zlhwndOutput Then If bAddLineFeed Then 'Add a line feed sText = sText & vbCrLf End If WriteOutput = WriteConsole(zlhwndOutput, ByVal sText, Len(sText), lNumWritten, ByVal 0&) End If End Function 'Purpose : Reads any data the user enters into the console window. 'Inputs : [lNumChars] If specified the number of characters to read, ' else reads all data on window in the consoles ' input buffer. 'Outputs : Returns the input typed into the console window. 'Author : Andrew Baker 'Date : 15/01/2001 11:55 'Notes : 'Revisions : 'Assumptions : 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 'Bring the console window to the foreground SetForegroundWindow zlhwndConsole 'Create intial buffer to read input from console window lNumCharsToRead = clMaxChars sBuffer = String(clMaxChars, 0) Do lNumReads = lNumReads + 1 'The following line will halt the execution until the user presses 'Enter/Return in the console window (assuming the console is in 'ENABLE_LINE_INPUT mode). The input is then read into the buffer lSuccess = ReadConsole(zlhwndInput, ByVal sBuffer, clMaxChars, lNumCharsRead, 0&) If lSuccess = 0 Or lNumCharsRead < clMaxChars Or Right$(sBuffer, 2) = vbNewLine Then 'Finished reading input ReadUserInput = ReadUserInput & Left$(sBuffer, lNumCharsRead) Exit Do End If 'Store buffer ReadUserInput = ReadUserInput & sBuffer Loop End If End Function 'Purpose : Deletes the terminate button (or X button) on a dialog. 'Inputs : sDialogCaption The caption of the dialog whose X (terminate) menu you want to disable. ' [lHandle] If specified operates on this window, else finds the handle from ' the dialog caption. 'Outputs : Returns True on success. 'Author : Andrew Baker 'Date : 30/05/2000 'Notes : 'Revisions : Added code to refresh menu bar. Private Function zDialogDisableX(sDialogCaption As String, Optional lHandle As Long) As Boolean Const clXIndex As Long = 6 Const MfByPosition As Long = &H400 ' Deletes the menus by position (this is our default). ' Only continue if the passed window handle isn't zero. If lHandle <> 0 Then zDialogDisableX = DeleteMenu(GetSystemMenu(lHandle, False), clXIndex, MfByPosition) 'Refresh the dialog menu bar Call DrawMenuBar(lHandle) End If End Function Private Sub Class_Terminate() Terminate End Sub 'Purpose : Property for the caption of the console window 'Inputs : N/A 'Outputs : Returns/sets the console caption 'Author : Andrew Baker 'Date : 15/01/2001 11:55 'Notes : 'Revisions : 'Assumptions : Property Get Caption() As String Caption = zsCaption End Property Property Let Caption(Value As String) If SetConsoleTitle(Value) Then 'Succeeded zsCaption = Value End If End Property 'Purpose : The consoles window handle 'Inputs : N/A 'Outputs : Returns the consoles window handle 'Author : Andrew Baker 'Date : 15/01/2001 11:55 'Notes : 'Revisions : 'Assumptions : Property Get WindowHandle() As Long WindowHandle = zlhwndConsole End Property 'Purpose : Shells a command line (asychronously) into the current console 'Inputs : The name of the files (usually a batch file) to run, which ' returns DOS output. 'Outputs : N/A 'Author : Andrew Baker 'Date : 15/01/2001 11:55 'Notes : 'Revisions : 'Assumptions : Sub Shell(sCommandLine) VBA.Shell sCommandLine End Sub 'Purpose : Sets/returns the current input mode of a console's input buffer or ' the current output mode of a console screen buffer 'Inputs : An eConsoleState enum. See notes in declaration section 'Outputs : An eConsoleState enum. See notes in declaration section 'Author : Andrew Baker 'Date : 15/01/2001 11:55 'Notes : 'Revisions : 'Assumptions : 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 '--------DEMONSTRATION CODE---------- Private Sub Test() Set oDOS = New clsDOS oDOS.Initialise True 'Ask the user for input data oDOS.WriteOutput "Please enter your name:" Debug.Print oDOS.ReadUserInput 'Output a batch file to the window (asychronous) oDOS.Shell "C:\test.bat" 'Close DOS the window oDOS.Terminate End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
