home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / UnLocker2160148172009.psc / MConsole.bas < prev   
BASIC Source File  |  2009-08-17  |  53KB  |  1,262 lines
  1. Attribute VB_Name = "Con"
  2. ' *************************************************************************
  3. '  Copyright ⌐1996-2009 Karl E. Peterson
  4. '  All Rights Reserved, http://vb.mvps.org/
  5. ' *************************************************************************
  6. '  You are free to use this code within your own applications, but you
  7. '  are expressly forbidden from selling or otherwise distributing this
  8. '  source code, non-compiled, without prior written consent.
  9. ' *************************************************************************
  10. '  Redistributed - with full permission - on http://www.vbadvance.com
  11. ' *************************************************************************
  12. '  Portions blatently "stolen" from Peter Young, author of vbAdvance (the
  13. '  tool I use to compile VB5/6 console applications), who contributed the
  14. '  notion of creating a lightweight COM object rather than use a full-blown
  15. '  class in order to allow for the callback handling within a single module.
  16. '  For a very cool tool, see: http://www.vbadvance.com
  17. ' *************************************************************************
  18. '  Release History.
  19. '  Version 1.00 - February 2004
  20. '   * Initial release with vbAdvance (v3.00).
  21. '  Version 1.01 - March 16, 2004
  22. '   * Added assignment to m_hWnd in Initialize, which allows all usage of
  23. '     that variable to actually work prior to explicit call to hWnd prop.
  24. '   * Changed Initialize to return ConsoleLaunchModes enum.
  25. '   * Added ParentProcessID r/o property.
  26. '   * Added ParentFileName r/o property.
  27. '   * Added LaunchType r/o property.
  28. '   * Added GetProcessParent private method.
  29. '   * Added GetProcessFileName private method.
  30. '   * Added FindConsole private method.
  31. '   * Added numerous declares to support new properties and methods!
  32. '  Version 1.02 - March 18, 2004
  33. '   * Added TaskVisible public property.
  34. '  Version 1.03 - June 8, 2006
  35. '   * Added FlashWindow public method.
  36. '   * Added ReadChar public method.
  37. '   * Added ReadPassword public method.
  38. ' *************************************************************************
  39. Option Explicit
  40.  
  41. ' Console related Win32 API declarations
  42. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  43. Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
  44. Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
  45. Private Declare Function ReadFileEx Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpOverlapped As Any, ByVal lpCompletionRoutine As Long) As Long
  46. Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
  47. Private Declare Function WriteFileEx Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpOverlapped As Any, ByVal lpCompletionRoutine As Long) As Long
  48. Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
  49. Private Declare Function SetStdHandle Lib "kernel32" (ByVal nStdHandle As Long, ByVal nHandle As Long) As Long
  50. Private Declare Function AllocConsole Lib "kernel32" () As Long
  51. Private Declare Function FreeConsole Lib "kernel32" () As Long
  52.  
  53. Private Declare Function PeekConsoleInput Lib "kernel32" Alias "PeekConsoleInputA" (ByVal hConsoleInput As Long, ByRef lpBuffer As Any, ByVal nRecords As Long, ByRef lpNumberOfEventsRead As Long) As Long
  54. Private Declare Function GetNumberOfConsoleInputEvents Lib "kernel32" (ByVal hConsoleInput As Long, ByRef lpNumberOfEvents As Long) As Long
  55. Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long
  56. Private Declare Function ReadConsoleOutput Lib "kernel32" Alias "ReadConsoleOutputA" (ByVal hConsoleOutput As Long, lpBuffer As CHAR_INFO, dwBufferSize As COORD, dwBufferCoord As COORD, lpReadRegion As SMALL_RECT) As Long
  57. Private Declare Function ReadConsoleOutputAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, lpAttribute As Long, ByVal nLength As Long, dwReadCoord As COORD, lpNumberOfAttrsRead As Long) As Long
  58. Private Declare Function ReadConsoleOutputCharacter Lib "kernel32" Alias "ReadConsoleOutputCharacterA" (ByVal hConsoleOutput As Long, ByVal lpCharacter As String, ByVal nLength As Long, dwReadCoord As COORD, lpNumberOfCharsRead As Long) As Long
  59. Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
  60. Private Declare Function WriteConsoleOutput Lib "kernel32" Alias "WriteConsoleOutputA" (ByVal hConsoleOutput As Long, lpBuffer As CHAR_INFO, dwBufferSize As COORD, dwBufferCoord As COORD, lpWriteRegion As SMALL_RECT) As Long
  61. Private Declare Function WriteConsoleOutputAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, lpAttribute As Integer, ByVal nLength As Long, dwWriteCoord As COORD, lpNumberOfAttrsWritten As Long) As Long
  62. Private Declare Function WriteConsoleOutputCharacter Lib "kernel32" Alias "WriteConsoleOutputCharacterA" (ByVal hConsoleOutput As Long, ByVal lpCharacter As String, ByVal nLength As Long, dwWriteCoord As COORD, lpNumberOfCharsWritten As Long) As Long
  63. Private Declare Function FlushConsoleInputBuffer Lib "kernel32" (ByVal hConsoleInput As Long) As Long
  64. Private Declare Function ReadConsoleInput Lib "kernel32" Alias "ReadConsoleInputA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsRead As Long) As Long
  65. Private Declare Function WriteConsoleInput Lib "kernel32" Alias "WriteConsoleOutputA" (ByVal hConsoleInput As Long, ByVal lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsWritten As Long) As Long
  66.  
  67. Private Declare Function GetConsoleCursorInfo Lib "kernel32" (ByVal hConsoleOutput As Long, lpConsoleCursorInfo As CONSOLE_CURSOR_INFO) As Long
  68. Private Declare Function GetConsoleMode Lib "kernel32" (ByVal hConsoleHandle As Long, lpMode As Long) As Long
  69. Private Declare Function GetConsoleScreenBufferInfo Lib "kernel32" (ByVal hConsoleOutput As Long, lpConsoleScreenBufferInfo As CONSOLE_SCREEN_BUFFER_INFO) As Long
  70. Private Declare Function GetConsoleTitle Lib "kernel32" Alias "GetConsoleTitleA" (ByVal lpConsoleTitle As String, ByVal nSize As Long) As Long
  71. Private Declare Function SetConsoleActiveScreenBuffer Lib "kernel32" (ByVal hConsoleOutput As Long) As Long
  72. Private Declare Function SetConsoleCtrlHandler Lib "kernel32" (ByVal HandlerRoutine As Long, ByVal Add As Long) As Long
  73. Private Declare Function SetConsoleCursorInfo Lib "kernel32" (ByVal hConsoleOutput As Long, lpConsoleCursorInfo As CONSOLE_CURSOR_INFO) As Long
  74. Private Declare Function SetConsoleCursorPosition Lib "kernel32" (ByVal hConsoleOutput As Long, dwCursorPosition As Any) As Long
  75. Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleHandle As Long, ByVal dwMode As Long) As Long
  76. Private Declare Function SetConsoleScreenBufferSize Lib "kernel32" (ByVal hConsoleOutput As Long, dwSize As Any) As Long
  77. Private Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long
  78. Private Declare Function SetConsoleTitle Lib "kernel32" Alias "SetConsoleTitleA" (ByVal lpConsoleTitle As String) As Long
  79. Private Declare Function SetConsoleWindowInfo Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal bAbsolute As Long, lpConsoleWindow As SMALL_RECT) As Long
  80.  
  81. Private Declare Function GetConsoleCP Lib "kernel32" () As Long
  82. Private Declare Function SetConsoleCP Lib "kernel32" (ByVal wCodePageID As Integer) As Long
  83. Private Declare Function GetConsoleOutputCP Lib "kernel32" () As Long
  84. Private Declare Function SetConsoleOutputCP Lib "kernel32" (ByVal wCodePageID As Integer) As Long
  85. Private Declare Function GetConsoleDisplayMode Lib "kernel32" (lpModeFlags As Long) As Long
  86. Private Declare Function SetConsoleDisplayMode Lib "kernel32" (ByVal hConsoleHandle As Long, ByVal dwConsoleDisplayMode As Long, dwPreviousDisplayMode As Long) As Long
  87. Private Declare Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" (ByVal lpszSrc As String, lpszDst As Any, ByVal cchDstLength As Long) As Long
  88. Private Declare Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" (ByVal lpszSrc As String, lpszDst As Any, ByVal cchDstLength As Long) As Long
  89.  
  90. ' PSAPI Declares (available only in NT4 and later!)...
  91. ' Although, this download *used* to be offered for NT 3.51 as well:
  92. ' http://www.microsoft.com/downloads/details.aspx?displaylang=en&FamilyID=3D1FBAED-D122-45CF-9D46-1CAE384097AC
  93. Private Declare Function GetModuleFileNameEx Lib "PSAPI" Alias "GetModuleFileNameExA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, nSize As Long) As Long
  94.  
  95. ' Process info API declarations - NT4 and earlier - undocumented.
  96. Private Declare Function NtQueryInformationProcess Lib "ntdll" (ByVal ProcessHandle As Long, ByVal ProcessInformationClass As SYSTEM_INFORMATION_CLASS, ByRef ProcessInformation As Any, ByVal lProcessInformationLength As Long, ByRef lReturnLength As Long) As Long
  97.  
  98. ' Process info API declarations - 9x/NT5+
  99. Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
  100. Private Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long
  101. Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long
  102.  
  103. ' NT5 (Windows 2000) and later, only!
  104. Private Declare Function GetConsoleWindow Lib "kernel32" () As Long
  105.  
  106. ' Other Win32 API declarations.
  107. Private Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As Long, ByVal lParam As Long) As Long
  108. Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
  109. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  110. Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
  111. Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
  112. Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
  113. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  114. Private Declare Function GetForegroundWindow Lib "user32" () As Long
  115. Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
  116. Private Declare Function AttachThreadInput Lib "user32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
  117. Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal revert As Long) As Long
  118. Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
  119. Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
  120. Private Declare Function IsZoomed Lib "user32" (ByVal hWnd As Long) As Long
  121. Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
  122. Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
  123. Private Declare Function FlashWindowEx Lib "user32" (pfi As FLASHWINFO) As Long
  124. Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As Any) As Long
  125. Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
  126. Private Declare Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As String)
  127.  
  128. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  129. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  130. Private Declare Function SleepEx Lib "kernel32" (ByVal dwMilliseconds As Long, ByVal bAlertable As Long) As Long
  131. Private Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long)
  132.  
  133. ' Used to determine if an API function is exported.
  134. Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
  135. Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
  136. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
  137. Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
  138.  
  139. ' Maximum path length (without special handling) in NT
  140. Private Const MAX_PATH As Long = 260&
  141.  
  142. ' Uncover process information on 9x/NT5+.
  143. Private Type PROCESSENTRY32
  144.    dwSize As Long
  145.    cntUsage As Long
  146.    th32ProcessID As Long
  147.    th32DefaultHeapID As Long
  148.    th32ModuleID As Long
  149.    cntThreads As Long
  150.    th32ParentProcessID As Long
  151.    pcPriClassBase As Long
  152.    dwFlags As Long
  153.    szExeFile As String * MAX_PATH
  154. End Type
  155.  
  156. ' Process information under NT4- (undoc'd)
  157. Public Type PROCESS_BASIC_INFORMATION
  158.    ExitStatus As Long
  159.    PebBaseAddress As Long
  160.    AffinityMask As Long
  161.    BasePriority As Long
  162.    UniqueProcessId As Long
  163.    InheritedFromUniqueProcessId As Long  ' ParentProcessID
  164. End Type
  165.  
  166. ' Process information types
  167. Private Enum SYSTEM_INFORMATION_CLASS
  168.    SystemBasicInformation = 0
  169.    SystemPerformanceInformation = 2
  170.    SystemTimeOfDayInformation = 3
  171.    SystemProcessInformation = 5
  172.    SystemProcessorPerformanceInformation = 8
  173.    SystemInterruptInformation = 23
  174.    SystemExceptionInformation = 33
  175.    SystemRegistryQuotaInformation = 37
  176.    SystemLookasideInformation = 45
  177. End Enum
  178.  
  179. ' Used to find hidden controller window.
  180. Private Const GWL_HWNDPARENT As Long = (-8)
  181. Private Const GWL_STYLE As Long = (-16)
  182. Private Const WS_SYSMENU As Long = &H80000
  183.  
  184. ' Toolhelp constants.
  185. Private Const TH32CS_SNAPPROCESS As Long = &H2&
  186.  
  187. ' Used by the OpenProcess API call
  188. Private Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
  189. Private Const PROCESS_QUERY_INFORMATION As Long = &H400
  190. Private Const PROCESS_VM_READ As Long = &H10
  191.  
  192. ' Some calls need to know OS
  193. Private Type OSVERSIONINFO
  194.    dwOSVersionInfoSize As Long
  195.    dwMajorVersion As Long
  196.    dwMinorVersion As Long
  197.    dwBuildNumber As Long
  198.    dwPlatformId As Long
  199.    szCSDVersion As String * 128
  200. End Type
  201.  
  202. ' Used with FlashWindowEx - Note Win98/2000+ only!
  203. Private Type FLASHWINFO
  204.    cbSize As Long
  205.    hWnd As Long
  206.    dwFlags As Long
  207.    uCount As Long
  208.    dwTimeOut As Long
  209. End Type
  210.  
  211. ' FlashWindow flag constants
  212. Private Const FLASHW_STOP As Long = 0&
  213. Private Const FLASHW_CAPTION As Long = 1&
  214. Private Const FLASHW_TRAY As Long = 2&
  215. Private Const FLASHW_ALL As Long = FLASHW_CAPTION Or FLASHW_TRAY
  216. Private Const FLASHW_TIMER As Long = 4&
  217. Private Const FLASHW_TIMERNOFG As Long = &HC&
  218.  
  219. ' Platform ID constants
  220. Private Const VER_PLATFORM_WIN32s As Long = &H0
  221. Private Const VER_PLATFORM_WIN32_WINDOWS As Long = &H1
  222. Private Const VER_PLATFORM_WIN32_NT As Long = &H2
  223.  
  224. ' Standard I/O handle constants.
  225. Private Const STD_ERROR_HANDLE          As Long = -12&
  226. Private Const STD_INPUT_HANDLE          As Long = -10&
  227. Private Const STD_OUTPUT_HANDLE         As Long = -11&
  228.  
  229. ' Used to understand console display mode.
  230. Private Const CONSOLE_WINDOWED As Long = 0
  231. Private Const CONSOLE_FULLSCREEN As Long = 1             ' fullscreen console
  232. Private Const CONSOLE_FULLSCREEN_HARDWARE As Long = 2    ' console owns the hardware
  233.  
  234. ' Input Mode flags:
  235. Private Const ENABLE_PROCESSED_INPUT    As Long = &H1&
  236. Private Const ENABLE_LINE_INPUT         As Long = &H2&
  237. Private Const ENABLE_ECHO_INPUT         As Long = &H4&
  238. Private Const ENABLE_WINDOW_INPUT       As Long = &H8&
  239. Private Const ENABLE_MOUSE_INPUT        As Long = &H10&
  240.  
  241. ' Output Mode flags:
  242. Private Const ENABLE_PROCESSED_OUTPUT   As Long = &H1&
  243. Private Const ENABLE_WRAP_AT_EOL_OUTPUT As Long = &H2&
  244.  
  245. ' Attributes flags.
  246. Private Const FOREGROUND_BLUE           As Long = &H1&    ' text color contains blue.
  247. Private Const FOREGROUND_GREEN          As Long = &H2&    ' text color contains green.
  248. Private Const FOREGROUND_RED            As Long = &H4&    ' text color contains red.
  249. Private Const FOREGROUND_INTENSITY      As Long = &H8&    ' text color is intensified.
  250. Private Const BACKGROUND_BLUE           As Long = &H10&   ' background color contains blue.
  251. Private Const BACKGROUND_GREEN          As Long = &H20&   ' background color contains green.
  252. Private Const BACKGROUND_RED            As Long = &H40&   ' background color contains red.
  253. Private Const BACKGROUND_INTENSITY      As Long = &H80&   ' background color is intensified.
  254.  
  255. ' Type of control signal received by the handler
  256. Private Const CTRL_C_EVENT = 0
  257. Private Const CTRL_BREAK_EVENT = 1
  258. Private Const CTRL_CLOSE_EVENT = 2
  259. '  3 is reserved!
  260. '  4 is reserved!
  261. Private Const CTRL_LOGOFF_EVENT = 5
  262. Private Const CTRL_SHUTDOWN_EVENT = 6
  263.  
  264. ' ShowWindow() Commands
  265. Private Const SW_HIDE = 0
  266. Private Const SW_SHOWNORMAL = 1
  267. Private Const SW_NORMAL = 1
  268. Private Const SW_SHOWMINIMIZED = 2
  269. Private Const SW_SHOWMAXIMIZED = 3
  270. Private Const SW_MAXIMIZE = 3
  271. Private Const SW_SHOWNOACTIVATE = 4
  272. Private Const SW_SHOW = 5
  273. Private Const SW_MINIMIZE = 6
  274. Private Const SW_SHOWMINNOACTIVE = 7
  275. Private Const SW_SHOWNA = 8
  276. Private Const SW_RESTORE = 9
  277. Private Const SW_SHOWDEFAULT = 10
  278. Private Const SW_FORCEMINIMIZE = 11
  279. Private Const SW_MAX = 11
  280.  
  281. ' Structures used with API.
  282. Private Type OVERLAPPED
  283.    Internal                            As Long
  284.    InternalHigh                        As Long
  285.    offset                              As Long
  286.    OffsetHigh                          As Long
  287.    hEvent                              As Long
  288. End Type
  289.  
  290. Private Type CHAR_INFO
  291.    Char                                As Integer
  292.    Attributes                          As Integer
  293. End Type
  294.  
  295. Private Type CONSOLE_CURSOR_INFO
  296.    dwSize                              As Long
  297.    bVisible                            As Long
  298. End Type
  299.  
  300. Private Type COORD
  301.    x                                   As Integer
  302.    y                                   As Integer
  303. End Type
  304.  
  305. Private Type SMALL_RECT
  306.    Left                                As Integer
  307.    Top                                 As Integer
  308.    Right                               As Integer
  309.    Bottom                              As Integer
  310. End Type
  311.  
  312. Private Type CONSOLE_SCREEN_BUFFER_INFO
  313.    dwSize                              As COORD
  314.    dwCursorPosition                    As COORD
  315.    wAttributes                         As Integer
  316.    srWindow                            As SMALL_RECT
  317.    dwMaximumWindowSize                 As COORD
  318. End Type
  319.  
  320. ' Combination of INPUT_RECORD and KEY_EVENT_RECORD structures.
  321. Private Type INPUT_KEY_EVENT_RECORD
  322.    EventType As Integer         '   WORD  EventType;
  323.    bKeyDown As Long             '   BOOL  bKeyDown;
  324.    wRepeatCount As Integer      '   WORD  wRepeatCount;
  325.    wVirtualKeyCode As Integer   '   WORD  wVirtualKeyCode;
  326.    wVirtualScanCode As Integer  '   WORD  wVirtualScanCode;
  327.    AsciiChar As Integer         '   CHAR  AsciiChar;
  328.    dwControlKeyState As Long    '   DWORD dwControlKeyState;
  329. End Type
  330.  
  331. ' Possible types of console events.
  332. Private Const KEY_EVENT As Integer = &H1                 ' Event contains key event record
  333. Private Const MOUSE_EVENT As Integer = &H2               ' Event contains mouse event record
  334. Private Const WINDOW_BUFFER_SIZE_EVENT As Integer = &H4  ' Event contains window change event record
  335. Private Const MENU_EVENT As Integer = &H8                ' Event contains menu event record
  336. Private Const FOCUS_EVENT As Integer = &H10              ' Event contains focus change
  337.  
  338. ' Structures used in creation of lightweight object.
  339. Private Type ConsoleType
  340.    pVTable As Long
  341.    pThisObject As IUnknown
  342. End Type
  343.  
  344. Private Type VTable
  345.    VTable(0 To 2) As Long
  346. End Type
  347.  
  348. ' Window class constant(s)
  349. Const ConsoleClassName As String = "ConsoleWindowClass"
  350. Const ConsoleClassName95 As String = "tty"
  351.  
  352. ' Member variables used to manage lightweight object.
  353. Private m_CT As ConsoleType
  354. Private m_VTable As VTable
  355. Private m_pVTable As Long
  356.  
  357. ' Task related member variables.
  358. Private m_StdError            As Long
  359. Private m_StdInput            As Long
  360. Private m_StdOutput           As Long
  361. Private m_OriginalInputMode   As Long
  362. Private m_OriginalOutputMode  As Long
  363. Private m_OriginalColors      As Long
  364. Private m_CloseProgram        As Boolean
  365. Private m_ControlEvent        As Long
  366. Private m_BackColor           As Long
  367. Private m_ForeColor           As Long
  368. Private m_Compiled            As Boolean
  369. Private m_Redirected          As Boolean
  370. Private m_ExitCode            As Long
  371. Private m_hWnd                As Long
  372. ' *** Added at v1.01 ***
  373. Private m_ParentProcessID     As Long
  374. Private m_ParentFilename      As String
  375.  
  376. ' Consumable enumerations
  377. Public Enum ConsoleControlSignals
  378.    conEventNone = -1
  379.    conEventControlC = CTRL_C_EVENT
  380.    conEventControlBreak = CTRL_BREAK_EVENT
  381.    conEventClose = CTRL_CLOSE_EVENT
  382.    conEventLogoff = CTRL_LOGOFF_EVENT
  383.    conEventShutdown = CTRL_SHUTDOWN_EVENT
  384. End Enum
  385.  
  386. Public Enum ConsoleWriteAlignments
  387.    conAlignNone
  388.    conAlignLeft
  389.    conAlignCentered
  390.    conAlignRight
  391. End Enum
  392.  
  393. Public Enum ConsoleOutputDestinations
  394.    conStandardOutput
  395.    conStandardError
  396. End Enum
  397.  
  398. ' *** Added v1.01 ***
  399. Public Enum ConsoleLaunchModes
  400.    conLaunchUnknown = 0  'indeterminate - NT versions prior to 4.0
  401.    conLaunchConsole = 1  'launched at command line.
  402.    conLaunchExplorer = 2 'double-clicked, from shortcut, etc.
  403.    conLaunchVBIDE = 4    'running within the IDE
  404. End Enum
  405.  
  406. ' Enumeration of character attributes.
  407. Public Enum ConsoleColors
  408.    [_ColorMin] = 0&
  409.    conBlack = 0&
  410.    conBlue = FOREGROUND_BLUE
  411.    conGreen = FOREGROUND_GREEN
  412.    conCyan = FOREGROUND_BLUE Or FOREGROUND_GREEN
  413.    conRed = FOREGROUND_RED
  414.    conMagenta = FOREGROUND_RED Or FOREGROUND_BLUE
  415.    conYellow = FOREGROUND_RED Or FOREGROUND_GREEN
  416.    conWhite = FOREGROUND_BLUE Or FOREGROUND_GREEN Or FOREGROUND_RED
  417.    conBlackHi = FOREGROUND_INTENSITY
  418.    conBlueHi = FOREGROUND_BLUE Or FOREGROUND_INTENSITY
  419.    conCyanHi = FOREGROUND_BLUE Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY
  420.    conGreenHi = FOREGROUND_GREEN Or FOREGROUND_INTENSITY
  421.    conRedHi = FOREGROUND_RED Or FOREGROUND_INTENSITY
  422.    conMagentaHi = FOREGROUND_RED Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY
  423.    conYellowHi = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY
  424.    conWhiteHi = FOREGROUND_BLUE Or FOREGROUND_GREEN Or FOREGROUND_RED Or FOREGROUND_INTENSITY
  425.    [_ColorMax] = FOREGROUND_BLUE Or FOREGROUND_GREEN Or FOREGROUND_RED Or FOREGROUND_INTENSITY
  426. End Enum
  427.  
  428. ' ******************************************
  429. '  Initialize / Terminate
  430. '    Release is called automatically when
  431. '    application is terminating.
  432. ' ******************************************
  433. Public Function Initialize() As ConsoleLaunchModes
  434.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  435.    Dim lpBuffer As Long, CharsRead As Long
  436.    Dim nRet As Long, nErr As Long
  437.    Const ERROR_INVALID_HANDLE As Long = 6
  438.    ' ****************************************************
  439.    ' If the VTable pointer is uninitialized, we haven't
  440.    ' been through this routine yet, so only do the init
  441.    ' stuff when that's the case...
  442.    ' ****************************************************
  443.    ' Create the lightweight COM object that provides
  444.    ' us with both automatic teardown notification,
  445.    ' and allows us to sink notifications directly.
  446.    If m_pVTable = 0 Then
  447.       With m_CT
  448.          If .pVTable = 0 Then
  449.             ' Create the lightweight's VTable:
  450.             With m_VTable
  451.                .VTable(0) = FuncPtr(AddressOf QueryInterface)
  452.                .VTable(1) = FuncPtr(AddressOf AddRef)
  453.                .VTable(2) = FuncPtr(AddressOf Release)
  454.                m_pVTable = VarPtr(.VTable(0))
  455.             End With
  456.             ' Finish setting up the lightweight.
  457.             .pVTable = m_pVTable
  458.             CopyMemory .pThisObject, VarPtr(.pVTable), 4
  459.          End If
  460.       End With
  461.  
  462.       ' Create a console to play in, if running in the IDE.
  463.       ' Cache handle to console window, either way.
  464.       m_Compiled = IsCompiled()
  465.       If m_Compiled Then
  466.          ' *** Added in v1.01 ***
  467.          m_hWnd = Con.hWnd
  468.       Else
  469.          ' *** Changed in v1.01 ***
  470.          m_hWnd = LaunchConsole()
  471.       End If
  472.  
  473.       'Set up the handler callback.
  474.       Call SetConsoleCtrlHandler(AddressOf HandlerRoutine, True)
  475.  
  476.       ' Get the standard handles.
  477.       m_StdError = GetStdHandle(STD_ERROR_HANDLE)
  478.       m_StdInput = GetStdHandle(STD_INPUT_HANDLE)
  479.       m_StdOutput = GetStdHandle(STD_OUTPUT_HANDLE)
  480.       
  481.       ' Save the current INPUT and OUTPUT modes.
  482.       Call GetConsoleMode(m_StdInput, m_OriginalInputMode)
  483.       Call GetConsoleMode(m_StdOutput, m_OriginalOutputMode)
  484.  
  485.       ' Set a default INPUT mode.
  486.       Const defInputMode = ENABLE_LINE_INPUT Or _
  487.                            ENABLE_PROCESSED_INPUT Or _
  488.                            ENABLE_ECHO_INPUT
  489.       Call SetConsoleMode(m_StdInput, defInputMode)
  490.  
  491.       ' Set a default OUTPUT mode.
  492.       Const defOutputMode = ENABLE_PROCESSED_OUTPUT Or _
  493.                             ENABLE_WRAP_AT_EOL_OUTPUT
  494.       Call SetConsoleMode(m_StdOutput, defOutputMode)
  495.  
  496.       ' Get the current colors.
  497.       Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  498.       m_OriginalColors = csbi.wAttributes
  499.       m_BackColor = csbi.wAttributes \ &H10
  500.       m_ForeColor = csbi.wAttributes Mod &H10
  501.  
  502.       ' Test to see whether standard input has been redirected.
  503.       ' In this case, Err.LastDllError returns 0, oddly enough.
  504.       ' Source: Dr. GUI, July 2003, "Do You Know Where That Stream's Been?"
  505.       ' http://msdn.microsoft.com/library/en-us/dnaskdr/html/askgui07152003.asp
  506.       nRet = PeekConsoleInput(m_StdInput, lpBuffer, 0, CharsRead)
  507.       nErr = Err.LastDllError
  508.       m_Redirected = (nRet = 0) And (nErr = ERROR_INVALID_HANDLE)
  509.       
  510.       ' Initial control signal status.
  511.       m_ControlEvent = conEventNone
  512.       
  513.       ' *** Added at v1.01 ***
  514.       ' Determine parent process name, cache.
  515.       m_ParentFilename = GetProcessParent()
  516.       
  517.       ' *** Added at v1.02 ***
  518.       ' Hide hidden controller window so we disappear from
  519.       ' Applications tab in Task Manager.
  520.       Const defTaskVisible As Boolean = False
  521.       Con.TaskVisible = defTaskVisible
  522.       
  523.       ' *** Added at v1.01 ***
  524.       ' Assign LaunchMode to retval.
  525.       Initialize = LaunchMode()
  526.    End If
  527. End Function
  528.  
  529. ' *****************************************************
  530. '  Lightweight object's Release method will be called
  531. '  automatically when application terminates.
  532. '  Release, in turn, calls Terminate to perform all
  533. '  task-related clean-up activities.
  534. ' *****************************************************
  535. Private Sub Terminate()
  536.    ' Restore original colors
  537.    Call SetConsoleTextAttribute(m_StdOutput, m_OriginalColors)
  538.  
  539.    ' Restore original INPUT and OUTPUT modes
  540.    Call SetConsoleMode(m_StdInput, m_OriginalInputMode)
  541.    Call SetConsoleMode(m_StdOutput, m_OriginalOutputMode)
  542.  
  543.    ' Kill off IDE-hosted console, after pausing
  544.    ' to allow results to be viewed.
  545.    If Not m_Compiled Then
  546.       Call Con.SetFocus(True)
  547.       Con.PressAnyKey vbCrLf & vbCrLf & _
  548.          " --- Execution Complete: Press any key to return to the IDE --- "
  549.       Call FreeConsole
  550.    End If
  551.  
  552.    ' Close all the standard handles
  553.    Call CloseHandle(m_StdError)
  554.    Call CloseHandle(m_StdInput)
  555.    Call CloseHandle(m_StdOutput)
  556.    
  557.    ' Return appropriate exit code, but *only*
  558.    ' if running from EXE, else IDE exits too.
  559.    ' App *must* be compiled to native code to
  560.    ' avoid a nasty shutdown GPF in runtime!
  561.    If m_Compiled Then
  562.       Call ExitProcess(m_ExitCode)
  563.    End If
  564. End Sub
  565.  
  566. ' ******************************************
  567. '  Public Properties: Read/Write
  568. ' ******************************************
  569. Public Property Let BackColor(ByVal NewBackColor As ConsoleColors)
  570.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  571.    ' Attempt to set a new backcolor.
  572.    If NewBackColor >= [_ColorMin] And NewBackColor <= [_ColorMax] Then
  573.       Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  574.       m_ForeColor = csbi.wAttributes Mod &H10
  575.       m_BackColor = NewBackColor * &H10
  576.       Call SetConsoleTextAttribute(m_StdOutput, m_ForeColor Or m_BackColor)
  577.    End If
  578. End Property
  579.  
  580. Public Property Get BackColor() As ConsoleColors
  581.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  582.    ' Get the current colors, return backcolor.
  583.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  584.    m_BackColor = csbi.wAttributes \ &H10
  585.    BackColor = m_BackColor
  586. End Property
  587.  
  588. Public Property Let Break(ByVal NewVal As Boolean)
  589.    ' Give client a chance to reset this flag so it
  590.    ' can proceed to clean up after itself.
  591.    m_CloseProgram = NewVal
  592. End Property
  593.  
  594. Public Property Get Break() As Boolean
  595.    ' When the user attempts to manually shutdown
  596.    ' the console app, our Handler will be tickled
  597.    ' and set a flag that the process can check.
  598.    ' If the process ignores this flag, the system
  599.    ' tends to call ExitProcess in response.
  600.    Break = m_CloseProgram
  601. End Property
  602.  
  603. Public Property Let BufferHeight(ByVal NewHeight As Integer)
  604.    Dim sz As COORD
  605.    ' Attempt setting a new height for console buffer.
  606.    If NewHeight > 0 Then
  607.       sz.x = Con.BufferWidth
  608.       sz.y = NewHeight
  609.       Call SetConsoleScreenBufferSize(m_StdOutput, ByVal CoordToLong(sz))
  610.       Debug.Print "BufferHeight: "; Err.LastDllError
  611.    End If
  612. End Property
  613.  
  614. Public Property Get BufferHeight() As Integer
  615.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  616.    ' Return height of console buffer.
  617.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  618.    BufferHeight = csbi.dwSize.y
  619. End Property
  620.  
  621. Public Property Let BufferWidth(ByVal NewWidth As Integer)
  622.    Dim sz As COORD
  623.    ' Attempt setting a new width for console buffer.
  624.    If NewWidth > 0 Then
  625.       sz.x = NewWidth
  626.       sz.y = Con.BufferHeight
  627.       Call SetConsoleScreenBufferSize(m_StdOutput, ByVal CoordToLong(sz))
  628.    End If
  629. End Property
  630.  
  631. Public Property Get BufferWidth() As Integer
  632.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  633.    ' Return width of console buffer.
  634.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  635.    BufferWidth = csbi.dwSize.x
  636. End Property
  637.  
  638. Public Property Let CodePageI(ByVal NewCP As Integer)
  639.    ' Attempt to set current input codepage ID.
  640.    Call SetConsoleCP(NewCP)
  641. End Property
  642.  
  643. Public Property Get CodePageI() As Integer
  644.    ' Retrieve current input codepage ID.
  645.    CodePageI = GetConsoleCP()
  646. End Property
  647.  
  648. Public Property Let CodePageO(ByVal NewCP As Integer)
  649.    ' Attempt to set current output codepage ID.
  650.    Call SetConsoleOutputCP(NewCP)
  651. End Property
  652.  
  653. Public Property Get CodePageO() As Integer
  654.    ' Retrieve current input codepage ID.
  655.    CodePageO = GetConsoleOutputCP()
  656. End Property
  657.  
  658. Public Property Let CurrentX(ByVal NewPosition As Integer)
  659.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  660.    ' Determine current cursor position.
  661.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  662.    ' Clamping request at buffer extents in extreme cases.
  663.    If NewPosition > csbi.dwSize.x Then
  664.       csbi.dwCursorPosition.x = csbi.dwSize.x
  665.    ElseIf NewPosition < 0 Then
  666.       csbi.dwCursorPosition.x = 0
  667.    Else
  668.       csbi.dwCursorPosition.x = NewPosition
  669.    End If
  670.    ' Attempt to set new cursor position.
  671.    Call SetConsoleCursorPosition(m_StdOutput, ByVal CoordToLong(csbi.dwCursorPosition))
  672. End Property
  673.  
  674. Public Property Get CurrentX() As Integer
  675.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  676.    ' Return X-position of cursor; 0-based.
  677.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  678.    CurrentX = csbi.dwCursorPosition.x
  679. End Property
  680.  
  681. Public Property Let CurrentY(ByVal NewPosition As Integer)
  682.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  683.    ' Determine current cursor position.
  684.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  685.    ' Clamping request at buffer extents in extreme cases.
  686.    If NewPosition > csbi.dwSize.y Then
  687.       csbi.dwCursorPosition.y = csbi.dwSize.y
  688.    ElseIf NewPosition < 0 Then
  689.       csbi.dwCursorPosition.y = 0
  690.    Else
  691.       csbi.dwCursorPosition.y = NewPosition
  692.    End If
  693.    ' Attempt to set new cursor position.
  694.    Call SetConsoleCursorPosition(m_StdOutput, ByVal CoordToLong(csbi.dwCursorPosition))
  695. End Property
  696.  
  697. Public Property Get CurrentY() As Integer
  698.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  699.    ' Return Y-position of cursor; 0-based.
  700.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  701.    CurrentY = csbi.dwCursorPosition.y
  702. End Property
  703.  
  704. Public Property Let CursorHeight(ByVal NewPercentage As Integer)
  705.    Dim cci As CONSOLE_CURSOR_INFO
  706.    ' Cursor height is restricted to 1-100% of cell size.
  707.    If NewPercentage >= 1 And NewPercentage <= 100 Then
  708.       ' Get current values.
  709.       Call GetConsoleCursorInfo(m_StdOutput, cci)
  710.       cci.dwSize = NewPercentage
  711.       Call SetConsoleCursorInfo(m_StdOutput, cci)
  712.    End If
  713. End Property
  714.  
  715. Public Property Get CursorHeight() As Integer
  716.    Dim cci As CONSOLE_CURSOR_INFO
  717.    ' Return cursor height as a percentage of character cell size.
  718.    Call GetConsoleCursorInfo(m_StdOutput, cci)
  719.    CursorHeight = cci.dwSize
  720. End Property
  721.  
  722. Public Property Let CursorVisible(ByVal NewVisible As Boolean)
  723.    Dim cci As CONSOLE_CURSOR_INFO
  724.    ' Get current values, and set as requested.
  725.    Call GetConsoleCursorInfo(m_StdOutput, cci)
  726.    cci.bVisible = NewVisible
  727.    Call SetConsoleCursorInfo(m_StdOutput, cci)
  728. End Property
  729.  
  730. Public Property Get CursorVisible() As Boolean
  731.    Dim cci As CONSOLE_CURSOR_INFO
  732.    ' Return cursor visibility.
  733.    Call GetConsoleCursorInfo(m_StdOutput, cci)
  734.    CursorVisible = cci.bVisible
  735. End Property
  736.  
  737. Public Property Let ExitCode(ByVal NewExitCode As Long)
  738.    ' Simply stash exitcode to use as app is terminating.
  739.    m_ExitCode = NewExitCode
  740. End Property
  741.  
  742. Public Property Get ExitCode() As Long
  743.    ' Return cached value.
  744.    ExitCode = m_ExitCode
  745. End Property
  746.  
  747. Public Property Let ForeColor(ByVal NewForeColor As ConsoleColors)
  748.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  749.    ' Attempt to set a new forecolor.
  750.    If NewForeColor >= [_ColorMin] And NewForeColor <= [_ColorMax] Then
  751.       Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  752.       m_BackColor = (csbi.wAttributes \ &H10) * &H10
  753.       m_ForeColor = NewForeColor
  754.       Call SetConsoleTextAttribute(m_StdOutput, m_ForeColor Or m_BackColor)
  755.    End If
  756. End Property
  757.  
  758. Public Property Get ForeColor() As ConsoleColors
  759.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  760.    ' Get the current colors, return forecolor.
  761.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  762.    m_ForeColor = csbi.wAttributes Mod &H10
  763.    ForeColor = m_ForeColor
  764. End Property
  765.  
  766. Public Property Let FullScreen(ByVal NewVal As Boolean)
  767.    Dim lpModeFlags As Long
  768.    Dim dwPrevMode As Long
  769.    ' Attempt to set full-screen status.  Not supported on Win9x!
  770.    If Exported("kernel32", "SetConsoleDisplayMode") = False Or _
  771.       Exported("kernel32", "GetConsoleDisplayMode") = False Then
  772.       ' No need to continue!
  773.       Exit Property
  774.    End If
  775.  
  776.    ' Make sure there is a need to change.
  777.    If GetConsoleDisplayMode(lpModeFlags) Then
  778.       If CBool(lpModeFlags And CONSOLE_FULLSCREEN_HARDWARE) Then
  779.          If NewVal = False Then
  780.             ' We are currently running full-screen,
  781.             ' and we need to switch to windowed.
  782.             Call SetConsoleDisplayMode(m_StdOutput, 0&, dwPrevMode)
  783.          End If
  784.       Else
  785.          If NewVal = True Then
  786.             ' We are currently running windowed, and
  787.             ' we need to switch to full-screen.
  788.             Call SetConsoleDisplayMode(m_StdOutput, 1&, dwPrevMode)
  789.          End If
  790.       End If
  791.    End If
  792. End Property
  793.  
  794. Public Property Get FullScreen() As Boolean
  795.    Dim lpModeFlags As Long
  796.    ' Attempt to set full-screen status.  Not supported on Win9x!
  797.    If Exported("kernel32", "GetConsoleDisplayMode") Then
  798.       If GetConsoleDisplayMode(lpModeFlags) Then
  799.          FullScreen = CBool(lpModeFlags And CONSOLE_FULLSCREEN_HARDWARE)
  800.       End If
  801.    End If
  802. End Property
  803.  
  804. Public Property Let Height(ByVal NewHeight As Integer)
  805.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  806.    ' Determine maximum height (chars) of console window.
  807.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  808.    ' Adjust structure elements to be sure they're 0-based.
  809.    csbi.srWindow.Top = 0
  810.    csbi.srWindow.Right = csbi.srWindow.Right - csbi.srWindow.Left
  811.    csbi.srWindow.Left = 0
  812.    ' Make sure requested height is valid (0-based).
  813.    If NewHeight > csbi.dwMaximumWindowSize.y Then
  814.       csbi.srWindow.Bottom = csbi.dwMaximumWindowSize.y - 1
  815.    Else
  816.       csbi.srWindow.Bottom = NewHeight - 1
  817.    End If
  818.    ' Attempt setting new console window height.
  819.    Call SetConsoleWindowInfo(m_StdOutput, True, csbi.srWindow)
  820. End Property
  821.  
  822. Public Property Get Height() As Integer
  823.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  824.    ' Return height (chars) of console window.
  825.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  826.    Height = csbi.srWindow.Bottom - csbi.srWindow.Top + 1
  827. End Property
  828.  
  829. Public Property Let TaskVisible(ByVal NewVal As Boolean)
  830.    ' Attempt to set task's current visibility state.
  831.    ' This affects the Applications tab in Task Manager.
  832.    ' If True, there are two icons - one for the console
  833.    ' task itself, and one for this task running within
  834.    ' the console.  If false, only the console icon shows.
  835.    If NewVal Then
  836.       Call ShowWindow(FindHiddenTopWindow(), SW_SHOW)
  837.    Else
  838.       Call ShowWindow(FindHiddenTopWindow(), SW_HIDE)
  839.    End If
  840. End Property
  841.  
  842. Public Property Get TaskVisible() As Boolean
  843.    ' Return current state of task visibility.
  844.    TaskVisible = IsWindowVisible(FindHiddenTopWindow())
  845. End Property
  846.  
  847. Public Property Let Title(ByVal NewTitle As String)
  848.    ' Update the console title text
  849.    Call SetConsoleTitle(NewTitle)
  850. End Property
  851.  
  852. Public Property Get Title() As String
  853.    Dim Buffer As String
  854.    Dim nRet As Long
  855.    ' Read title text of console
  856.    Buffer = Space$(1024)
  857.    nRet = GetConsoleTitle(Buffer, Len(Buffer))
  858.    If nRet Then
  859.       Title = Left$(Buffer, nRet)
  860.    End If
  861. End Property
  862.  
  863. Public Property Let Visible(ByVal NewVal As Boolean)
  864.    ' Attempt to set current visibility state.
  865.    If NewVal Then
  866.       Call ShowWindow(m_hWnd, SW_SHOW)
  867.    Else
  868.       Call ShowWindow(m_hWnd, SW_HIDE)
  869.    End If
  870. End Property
  871.  
  872. Public Property Get Visible() As Boolean
  873.    ' Return current state of visibility.
  874.    Visible = IsWindowVisible(m_hWnd)
  875. End Property
  876.  
  877. Public Property Let Width(ByVal NewWidth As Integer)
  878.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  879.    ' Determine maximum height (chars) of console window.
  880.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  881.    ' Adjust structure elements to be sure they're 0-based.
  882.    csbi.srWindow.Left = 0
  883.    csbi.srWindow.Bottom = csbi.srWindow.Bottom - csbi.srWindow.Top
  884.    csbi.srWindow.Top = 0
  885.    ' Make sure requested height is valid (0-based).
  886.    If NewWidth > csbi.dwMaximumWindowSize.x Then
  887.       csbi.srWindow.Right = csbi.dwMaximumWindowSize.x - 1
  888.    Else
  889.       csbi.srWindow.Right = NewWidth - 1
  890.    End If
  891.    ' Attempt setting new console window height.
  892.    Call SetConsoleWindowInfo(m_StdOutput, True, csbi.srWindow)
  893. End Property
  894.  
  895. Public Property Get Width() As Integer
  896.    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
  897.    ' Return width (chars) of console window.
  898.    Call GetConsoleScreenBufferInfo(m_StdOutput, csbi)
  899.    Width = csbi.srWindow.Right - csbi.srWindow.Left + 1
  900. End Property
  901.  
  902. Public Property Let WindowState(ByVal NewState As FormWindowStateConstants)
  903.    ' Set new state as requested.
  904.    Select Case NewState
  905.       Case vbNormal
  906.          Call ShowWindow(m_hWnd, SW_RESTORE)
  907.       Case vbMinimized
  908.          Call ShowWindow(m_hWnd, SW_MINIMIZE)
  909.       Case vbMaximized
  910.          Call ShowWindow(m_hWnd, SW_MAXIMIZE)
  911.    End Select
  912. End Property
  913.  
  914. Public Property Get WindowState() As FormWindowStateConstants
  915.    ' Return current state.
  916.    If IsIconic(m_hWnd) Then
  917.       WindowState = vbMinimized
  918.    ElseIf IsZoomed(m_hWnd) Then
  919.       WindowState = vbMaximized
  920.    Else
  921.       WindowState = vbNormal
  922.    End If
  923. End Property
  924.  
  925. ' ******************************************
  926. '  Public Properties: Read-Only
  927. ' ******************************************
  928. Public Property Get ControlEvent() As ConsoleControlSignals
  929.    '  This property may be queried if the Break property is found to
  930.    '  be True. It indicates what sort of event occurred that
  931.    '  requires the application to shutdown.
  932.    ' ================================================================
  933.    '  Note: A Win95 bug prevents some events from signaling!
  934.    '  http://support.microsoft.com/default.aspx?scid=kb;en-us;130717
  935.    ' ================================================================
  936.    ControlEvent = m_ControlEvent
  937. End Property
  938.  
  939. Public Property Get Compiled() As Boolean
  940.    ' Return cached value.
  941.    Compiled = m_Compiled
  942. End Property
  943.  
  944. Public Property Get hStdErr() As Long
  945.    ' Return handle to standard error.
  946.    hStdErr = m_StdError
  947. End Property
  948.  
  949. Public Property Get hStdIn() As Long
  950.    ' Return handle to standard input.
  951.    hStdIn = m_StdInput
  952. End Property
  953.  
  954. Public Property Get hStdOut() As Long
  955.    ' Return handle to standard output.
  956.    hStdOut = m_StdOutput
  957. End Property
  958.  
  959. Public Property Get hWnd() As Long
  960.    ' 124103 - HOWTO: Obtain a Console Window Handle (HWND)
  961.    ' http://support.microsoft.com/default.aspx?scid=KB;en-us;q124103
  962.    Dim os As OSVERSIONINFO
  963.    Dim Title As String
  964.    Dim Unique As String
  965.    Dim nRet As Long
  966.  
  967.    ' Returned cached value, if possible.
  968.    If m_hWnd = 0 Then
  969.       ' Determine what operating system this is.
  970.       os.dwOSVersionInfoSize = Len(os)
  971.       Call GetVersionEx(os)
  972.  
  973.       If os.dwPlatformId = VER_PLATFORM_WIN32_NT _
  974.          And os.dwMajorVersion >= 5 Then
  975.          ' This is Windows2000 or later!
  976.          m_hWnd = GetConsoleWindow()
  977.  
  978.       Else ' Take the tortuous path...
  979.          ' Cache the associated title.
  980.          Title = Space$(1024)
  981.          nRet = GetConsoleTitle(Title, Len(Title))
  982.          If nRet Then
  983.             Title = Left$(Title, nRet)
  984.          End If
  985.  
  986.          ' Construct unique string to use as new title.
  987.          Unique = Format$(Now, "yyyymmddhhnnss") & Hex$(GetCurrentProcessId())
  988.  
  989.          ' Set new title to use for search.
  990.          If SetConsoleTitle(Unique) Then
  991.             ' Find window most likely to be our console.
  992.             m_hWnd = FindConsole(Unique)
  993.             ' Restore original title.
  994.             Call SetConsoleTitle(Title)
  995.          End If
  996.       End If
  997.    End If
  998.    hWnd = m_hWnd
  999. End Property
  1000.  
  1001. Public Property Get LaunchMode() As ConsoleLaunchModes
  1002.    ' *** Added at v1.01 (entire routine) ***
  1003.    ' Assumes parent name is found at Initialize.
  1004.    Dim ParentName As String
  1005.    Const OldAppMod As String = "winoa386.mod"
  1006.    
  1007.    ' On "advanced" operating systems, console apps will
  1008.    ' always be running under the process shown in
  1009.    ' %COMSPEC%, but on early 9x systems they'll be
  1010.    ' running under WINOA386.MOD
  1011.    ParentName = LCase$(m_ParentFilename)
  1012.    If Len(m_ParentFilename) Then
  1013.       If m_Compiled = False Then
  1014.          ' Running under the VB IDE.
  1015.          LaunchMode = conLaunchVBIDE
  1016.          
  1017.       ElseIf (LCase$(Environ("Comspec")) = ParentName) Then
  1018.          ' Ex: C:\WINNT\system32\cmd.exe
  1019.          LaunchMode = conLaunchConsole
  1020.          
  1021.       ElseIf (InStr(ParentName, OldAppMod) = (Len(ParentName) - Len(OldAppMod) + 1)) Then
  1022.          ' Ex: C:\WINDOWS\SYSTEM\WINOA386.MOD
  1023.          LaunchMode = conLaunchConsole
  1024.          
  1025.       Else
  1026.          ' Ex: C:\WINNT\Explorer.EXE
  1027.          LaunchMode = conLaunchExplorer
  1028.          
  1029.       End If
  1030.    Else
  1031.       ' This could happen in NT 3.51 and earlier,
  1032.       ' if PSAPI.DLL is not present.
  1033.       LaunchMode = conLaunchUnknown
  1034.       
  1035.    End If
  1036. End Property
  1037.  
  1038. Public Property Get ParentFileName() As String
  1039.    ' *** Added at v1.01 (entire routine) ***
  1040.    ParentFileName = m_ParentFilename
  1041. End Property
  1042.  
  1043. Public Property Get ParentProcessID() As Long
  1044.    ' *** Added at v1.01 (entire routine) ***
  1045.    ParentProcessID = m_ParentProcessID
  1046. End Property
  1047.  
  1048. Public Property Get Piped() As Boolean
  1049.    ' Just test this once, in Initialize...
  1050.    Piped = m_Redirected
  1051. End Property
  1052.  
  1053. Public Property Get Redirected() As Boolean
  1054.    ' Just test this once, in Initialize...
  1055.    Redirected = m_Redirected
  1056. End Property
  1057.  
  1058. ' ******************************************
  1059. '  Public Methods
  1060. ' ******************************************
  1061. Public Sub DebugOutput(ByVal Data As String, Optional ByVal CrLf As Boolean = True)
  1062.    ' ====================================================
  1063.    ' Highly recommended utility for reading this output
  1064.    ' from a compiled EXE -- DBWin32 by Grant Schenck:
  1065.    '  -- http://grantschenck.tripod.com/dbwinv2.htm
  1066.    ' ====================================================
  1067.    ' Output to the ether...  Someone may be listening...
  1068.    Debug.Print Data;
  1069.    Call OutputDebugString(Data)
  1070.    If CrLf Then
  1071.       Debug.Print
  1072.       Call OutputDebugString(vbCrLf)
  1073.    End If
  1074. End Sub
  1075.  
  1076. Public Sub FlashWindow(Optional ByVal Count As Long = 2, Optional ByVal Delay As Long = 250)
  1077.    Dim fwi As FLASHWINFO
  1078.    ' Assign some defaults
  1079.    With fwi
  1080.       .cbSize = Len(fwi)
  1081.       .hWnd = hWnd
  1082.       .dwFlags = FLASHW_ALL
  1083.       .uCount = Count
  1084.       .dwTimeOut = Delay
  1085.    End With
  1086.    ' This function only works on Win98+ and Win2000+.
  1087.    ' Gracefully degrade (fail) on older systems.
  1088.    On Error Resume Next
  1089.    Call FlashWindowEx(fwi)
  1090.    On Error GoTo 0
  1091. End Sub
  1092.  
  1093. Public Function Flush() As Boolean
  1094.    ' Flush the console input buffer of any
  1095.    ' waiting input records.
  1096.    Flush = CBool(FlushConsoleInputBuffer(m_StdInput))
  1097. End Function
  1098.  
  1099. Public Function ReadChar() As Byte   'KeyAscii
  1100.    Dim Mode As Long
  1101.    Dim Char As Byte
  1102.    Dim CharsRead As Long
  1103.  
  1104.    ' Flush input buffer.
  1105.    Call FlushConsoleInputBuffer(m_StdInput)
  1106.  
  1107.    ' Cache existing mode, so it can be restored.
  1108.    Call GetConsoleMode(m_StdInput, Mode)
  1109.  
  1110.    ' Set mode to not wait for an Enter key before returning.
  1111.    ' No echo of character, either.
  1112.    Call SetConsoleMode(m_StdInput, 0&)
  1113.  
  1114.    ' Wait for a single keystroke.
  1115.    Call ReadConsole(m_StdInput, Char, 1&, CharsRead, ByVal 0&)
  1116.  
  1117.    ' Restore original mode.
  1118.    Call SetConsoleMode(m_StdInput, Mode)
  1119.    
  1120.    ' Return KeyAscii value of the key user pressed,
  1121.    ' translated from OEM to current system codepage.
  1122.    ReadChar = Char
  1123. End Function
  1124.  
  1125. Public Function ReadLine(Optional ByVal Prompt As String = "", Optional NumChars As Long = 0) As String
  1126.    ' ===============================================================
  1127.    ' ReadConsole fails if input has been redirected, so we
  1128.    ' need to use ReadFile instead.  Under normal circumstances,
  1129.    ' ReadFile will keep going until the EOF is hit.  This is
  1130.    ' still represented by Cntl-Z.  For piped/redirected input,
  1131.    ' Windows provides Cntl-Z automatically.
  1132.    ' ===============================================================
  1133.    Dim Char As Byte
  1134.    Dim CharsRead As Long
  1135.    Dim sRet As String
  1136.    
  1137.    ' Write prompt to user, if provided.
  1138.    If Len(Prompt) Then
  1139.       Con.WriteLine Prompt, False
  1140.    End If
  1141.    
  1142.    ' ReadFile doesn't return until user presses Enter, or
  1143.    ' some form of Control-Break.  The strategy is to call it
  1144.    ' once, during which all input will be made and the first
  1145.    ' character returned.  Then call ReadFile repeatedly until
  1146.    ' queue is exhausted, which will be at the point where input
  1147.    ' was terminated (Enter/Cntl-C).
  1148.    Do
  1149.       Call ReadFile(m_StdInput, Char, 1&, CharsRead, ByVal 0&)
  1150.       If CharsRead Then
  1151.          DebugOutput Format$(Char, "000") & Space$(6) & IIf(Char > 27, Chr$(Char), "[ ]")
  1152.          
  1153.          If Char = 13 Then
  1154.             ' All done!  Pop the final LF off queue.
  1155.             Call ReadFile(m_StdInput, Char, 1&, CharsRead, ByVal 0&)
  1156.             Exit Do
  1157.          ElseIf Char = 10 Then
  1158.             ' Linefeed - ignore.
  1159.          Else
  1160.             ' Append to return string.
  1161.             sRet = sRet & Chr$(Char)
  1162.          End If
  1163.       End If
  1164.       
  1165.       ' Give Windows a chance to breathe...
  1166.       Call SleepEx(10, True)
  1167.       
  1168.       ' Display some indication if input was terminated.
  1169.       ' Break handler also terminates ReadFile call.
  1170.       If Con.Break Then
  1171.          If Con.ControlEvent = conEventControlBreak Or Con.ControlEvent = conEventControlC Then
  1172.             Con.WriteLine "^C"
  1173.          End If
  1174.          Exit Do
  1175.       End If
  1176.    Loop
  1177.    
  1178.    ' ReadFile doesn't return until user presses Enter,
  1179.    ' so the best we can do is read all keystrokes, then
  1180.    ' truncate at requested number.
  1181.    If NumChars Then
  1182.       sRet = Left$(sRet, NumChars)
  1183.    End If
  1184.    
  1185.    ' Assign results
  1186.    ReadLine = sRet
  1187. End Function
  1188.  
  1189. Public Function ReadPassword(Optional Prompt As String = "", Optional PasswordChar As String = "*") As String
  1190.    Dim Buffer As String
  1191.    Dim oemBuffer() As Byte
  1192.    Dim CharsWritten As Long
  1193.    Dim KeyAscii As Byte
  1194.    Dim cX As Long, cY As Long
  1195.  
  1196.    ' Make sure password character is no longer than 1-char.
  1197.    ' A zero-length string is valid, too.
  1198.    If Len(Trim$(PasswordChar)) > 1 Then
  1199.       PasswordChar = Left$(Trim$(PasswordChar), 1)
  1200.    End If
  1201.    
  1202.    ' Write prompt to user.
  1203.    If Len(Prompt) Then
  1204.       ' Translate from Windows ANSI to OEM codepage.
  1205.       ReDim oemBuffer(1 To Len(Prompt)) As Byte
  1206.       If CharToOemBuff(Prompt, oemBuffer(1), UBound(oemBuffer)) Then
  1207.          'Call WriteConsole(m_StdOutput, ByVal Prompt, Len(Prompt), CharsWritten, ByVal 0&)
  1208.          Call WriteConsole(m_StdOutput, oemBuffer(1), UBound(oemBuffer), CharsWritten, ByVal 0&)
  1209.       End If
  1210.    End If
  1211.    
  1212.    ' Cache starting location of cursor.
  1213.    cX = CurrentX
  1214.    cY = CurrentY
  1215.    
  1216.    ' Demonstrates how to effectively use the ReadChar function to
  1217.    ' process a single character at a time, until Enter is pressed.
  1218.    Do
  1219.       KeyAscii = ReadChar()
  1220.       Select Case KeyAscii
  1221.          Case vbKeyReturn, vbKeyTab
  1222.             Exit Do         ' All done!
  1223.          
  1224.          Case vbKeyBack     ' Jerk/User fat-fingered us...
  1225.             If Len(Buffer) Then
  1226.                ' Need to remove last char from buffer.
  1227.                Buffer = Left$(Buffer, Len(Buffer) - 1)
  1228.                
  1229.                ' This is where it may get really ugly!
  1230.                If Len(PasswordChar) Then
  1231.                   ' Reprint passwordchar string, minus one.
  1232.                   CurrentX = cX
  1233.                   CurrentY = cY
  1234.                   Prompt = String$(Len(Buffer), PasswordChar) & " "
  1235.                   ' Translate from ANSI to OEM.
  1236.                   ReDim oemBuffer(1 To Len(Prompt)) As Byte
  1237.                   If CharToOemBuff(Prompt, oemBuffer(1), UBound(oemBuffer)) Then
  1238.                      'Call WriteConsole(m_StdOutput, ByVal Prompt, Len(Prompt), CharsWritten, ByVal 0&)
  1239.                      Call WriteConsole(m_StdOutput, oemBuffer(1), UBound(oemBuffer), CharsWritten, ByVal 0&)
  1240.                   End If
  1241.                   
  1242.                   ' Back up one space.
  1243.                   If CurrentX = 0 Then 'zero-based!
  1244.                      ' Need to go up a row, and to end.
  1245.                      CurrentY = CurrentY - 1
  1246.                      CurrentX = Width - 1 'zero-based!
  1247.                   Else
  1248.                      ' Just back up on same rilename)  ' Back up     PasswordChar = ]")ic Property Lg
  1249.                         xp        e, so     Prompt = String$(Len(Buffer), Password COORsssword C C Then
  1250.        rMeturn ca rMeturn ca ecord
  1251. Prsword C C Then
  1252.        rtring$(Len(Buffer), PyDisplayMofm_StdOutp,isword C C ThCPput)M.
  1253.  YellowH, PyDispN            Unique = Format$(No) = FOREGRO      .A
  1254.       aa)     As Lo      Unique = Format$(No)ullttilenameNeed to go ut buff
  1255. Prsword C(No)ullttilenaLE_Ed Ty "o, Py PyDispN   As BN   As BN   As<'zee.
  1256.    co,-ntl-ZEAode As C C Then
  1257.   True)
  1258.    ' ==========wordCou For         ft$(Trim$d Ion if inpuLeft$(Tr(etem codsm(Prompl' Jerk/User fat-fing    SI to OEursWritN
  1259.    ' Flf      xp   earlier,
  1260.       ' if PSAPI.DLL is not presnaLE_Ed T'dhput hasad all keRcn  Unique = Formateu rEd T'dhpsm(al Prompte(m_StVal Delay Ase As -ZEAode As C C Then
  1261. Ascien(BuffvbCrLf)scien(Bbena                 ReDim oemBuffer(1 To =. ,(Len(Bl keR
  1262.      User fat-Ase As -ZEAoZEAode As CaeoreColor Or m_BackColor)            "