console.cls

来自「VB 加密----------能够加密解密控件」· CLS 代码 · 共 1,351 行 · 第 1/4 页

' the key that was pressed and modifier key states.
' @remarks This method blocks the calling thread until a key is pressed.
' <p>Not all keys are read and returned. Modifier keys (Alt, Shift, Control) are
' not returned, but instead, included in the <b>ConsoleKeyInfo</b> object when
' a normal key is pressed. This allows the status of the modifier keys to be
' known during a keypress, such as a Shift-A key combination.</b>
' <p>Keys that do not trigger this method to return are ALT, SHIFT, CONTROL, CAPS-LOCK, SCROLL-LOCK, and NUM-LOCK.</p>
'
Public Function ReadKey(Optional ByVal Intercept As Boolean = False) As ConsoleKeyInfo
    If Not InternalReadKey(ReadKey) Then
        Do
            Dim Result  As Long
            Dim NumRead As Long
            Result = ReadConsoleInput(mInputHandle, mKeyPressHistory, 1, NumRead)
            If Result = 0 Or NumRead = 0 Then _
                Throw Cor.NewInvalidOperationException("Could not read from the console window.")
            
            Dim ReRead As Boolean
            ReRead = (mKeyPressHistory.EventType <> KEY_EVENT)
            If Not ReRead Then ReRead = (mKeyPressHistory.KeyEvent.bKeyDown = BOOL_FALSE)
            If Not ReRead And (mKeyPressHistory.KeyEvent.uChar = 0) Then
                Select Case mKeyPressHistory.KeyEvent.wVirtualKeyCode
                    Case vbKeyShift, vbKeyMenu, vbKeyControl, vbKeyNumlock, vbKeyScrollLock, vbKeyCapital: ReRead = True
                End Select
            End If
        Loop While ReRead
        Call InternalReadKey(ReadKey)
    End If
    
    If Not Intercept Then Call WriteValue(ChrW$(mKeyPressHistory.KeyEvent.uChar))
End Function

''
' Sets the Console output to a new output TextWriter object.
'
' @param NewOut The TextWriter object that console output will be written to.
'
Public Sub SetOut(ByVal NewOut As TextWriter)
    If NewOut Is Nothing Then _
        Throw Cor.NewArgumentNullException("Cannot set output to Nothing.", "NewOut")
    
    Set mOutput = NewOut
    mOriginalOut = False
End Sub

''
' Sets the Console input source to a new TextReader object.
'
' @param NewIn The TextReader object the console retrieves input from.
'
Public Sub SetIn(ByVal NewIn As TextReader)
    If NewIn Is Nothing Then _
        Throw Cor.NewArgumentNullException("Cannot set input to Nothing.", "NewIn")
        
    Set mInput = NewIn
End Sub

''
' Sets the Console error output stream to the supplied TextWriter object.
'
' @param NewError The TextWriter object the console error data is written to.
'
Public Sub SetError(ByVal NewError As TextWriter)
    If NewError Is Nothing Then _
        Throw Cor.NewArgumentNullException("Cannot set error output to Nothing.", "NewError")
        
    Set mError = NewError
    mOriginalError = False
End Sub

''
' Returns the standard output stream.
'
' @return The standard output stream to write user data to.
' @remarks The standard output is the screen console.
'
Public Function OpenStandardOutput() As Stream
    Set OpenStandardOutput = GetConsoleStream(mOutputHandle, WriteAccess)
End Function

''
' Returns the standard input stream.
'
' @return The standard input stream object to retrieve user input from.
' @remarks The standard input is from the keyboard console.
'
Public Function OpenStandardInput() As Stream
    Set OpenStandardInput = GetConsoleStream(mInputHandle, ReadAccess)
End Function

''
' Returns the standard error stream.
'
' @return The standard error output stream that error data is written to.
' @remarks The standard error output is to the screen console.
'
Public Function OpenStandardError() As Stream
    Set OpenStandardError = GetConsoleStream(mErrorHandle, WriteAccess)
End Function

''
' Writes a value to the current output stream.
'
' @param values A set of zero or more parameters used to create a formatted string output.
'
' @remarks The first parameter is the string that will be written to
' the current output stream. All additional parameters will be used as
' formatting information in the first parameter. If no parameters are
' provided, then an empty string is written with a NewLine.
' @include "..\Includes\ConsoleWriteLine.txt"
Public Sub WriteLine(ParamArray Values() As Variant)
    Dim a() As Variant
    Call Helper.Swap4(ByVal ArrPtr(a), ByVal Helper.DerefEBP(12))
    Call InternalWriteLine(a)
End Sub

''
' Writes a string to the Console output stream without a NewLine break.
'
' @param value The value to write the string version of to the output stream.
' @param Args Values to be used in a formatted output.
' @remarks Values are converted to their string representation for text output.
' A formatted output can be created similar to <b>cString.Format</b>.
' @include "..\Includes\ConsoleWriteValue.txt"
Public Sub WriteValue(ByRef Value As Variant, ParamArray args() As Variant)
    Dim a() As Variant
    Call Helper.Swap4(ByVal ArrPtr(a), ByVal Helper.DerefEBP(16))
    Call InternalWriteValue(Value, a)
End Sub

''
' Produces a beep through the console.
'
' @param Frequency The frequency the beep will play at (default 800hz).
' @param Duration The milliseconds the beep should play for (default 200ms).
'
Public Sub Beep(Optional ByVal Frequency As Long = 800, Optional ByVal Duration As Long = 200)
    If Frequency < 37 Or Frequency > 32767 Then _
        Throw Cor.NewArgumentOutOfRangeException("Frequency must be between 37 and 32767.", "Frequency", Frequency)
    If Duration < 0 Then _
        Throw Cor.NewArgumentOutOfRangeException(Environment.GetResourceString(ArgumentOutOfRange_NeedNonNegNum), "Duration", Duration)
    
    If BeepAPI(Frequency, Duration) = BOOL_FALSE Then Throw Cor.NewSystemException(GetErrorMessage(Err.LastDllError))
End Sub

''
' Sets the size of the viewable window area for the console buffer.
'
' @param Width The width in characters.
' @param Height The height in characters.
' @param The underlying buffer is expanded to accomodate a larger viewing window.
' The buffer is not reduced in size for smaller viewing windows.
' @remarks The screen buffer is the virtual screen that is written to. The size
' of the buffer can be larger than the window inwhich it is being viewed through.
' The window's size can be changed to show a different size of the underlying
' screen buffer without altering the size of that buffer.
'
Public Sub SetWindowSize(ByVal Width As Long, ByVal Height As Long)
    If Width <= 0 Then _
        Throw Cor.NewArgumentOutOfRangeException("Width must be greater than zero.", "Width", Width)
    If Height <= 0 Then _
        Throw Cor.NewArgumentOutOfRangeException("Height must be greater than zero.", "Height", Height)
    
    With GetBufferInfo
        Dim ExpandBuffer    As Boolean
        Dim NewBufferSize   As COORD
        
        NewBufferSize = .dwSize
        Select Case .srWindow.Left + Width
            Case Is > MAX_WINDOW_SIZE
                Throw Cor.NewArgumentOutOfRangeException("Window width cannot extend beyond 32767 characters.", "Width", Width)
                
            Case Is > .dwSize.x
                NewBufferSize.x = .srWindow.Left + Width
                ExpandBuffer = True
        End Select
        Select Case .srWindow.Top + Height
            Case Is > MAX_WINDOW_SIZE
                Throw Cor.NewArgumentOutOfRangeException("Window height cannot extend beyond 32767 characters.", "Height", Height)
                
            Case Is > .dwSize.y
                NewBufferSize.y = .srWindow.Top + Height
                ExpandBuffer = True
        End Select
        
        If ExpandBuffer Then
            If SetConsoleScreenBufferSize(mOutputHandle, ByVal AsLong(NewBufferSize)) = BOOL_FALSE Then IOError Err.LastDllError
        End If
        
        Dim NewWindowSize As SMALL_RECT
        NewWindowSize = .srWindow
        NewWindowSize.Right = .srWindow.Left + Width - 1
        NewWindowSize.Bottom = .srWindow.Top + Height - 1
        If SetConsoleWindowInfo(mOutputHandle, True, NewWindowSize) = BOOL_FALSE Then
            Dim e As Long
            e = Err.LastDllError
            
            If ExpandBuffer Then
                ' restore buffer to original size
                If SetConsoleScreenBufferSize(mOutputHandle, ByVal AsLong(.dwSize)) = BOOL_FALSE Then IOError Err.LastDllError
            End If
            
            Dim MaxWindowSize As COORD
            MaxWindowSize = GetLargestConsoleWindowSize(mOutputHandle)
            If Width > MaxWindowSize.x Then _
                Throw Cor.NewArgumentOutOfRangeException("Width cannot be greater than the maximum window size for the current resolution.", "width", MaxWindowSize.x)
            If Height > MaxWindowSize.y Then _
                Throw Cor.NewArgumentOutOfRangeException("Height cannot be greater than the maximum window size for the current resolution.", "Height", MaxWindowSize.y)
            
            IOError e
        End If
    End With
End Sub

''
' Sets the position of the viewing window within the console screen buffer.
'
' @param Left The left position in characters.
' @param Top The top position in characters.
' @remarks The underlying screen buffer is not expanded to accomodate moving
' the window outside of the screen buffer.
'
Public Sub SetWindowPosition(ByVal Left As Long, ByVal Top As Long)
    If Left < 0 Then _
        Throw Cor.NewArgumentOutOfRangeException(Environment.GetResourceString(ArgumentOutOfRange_NeedNonNegNum), "Left", Left)
    If Top < 0 Then _
        Throw Cor.NewArgumentOutOfRangeException(Environment.GetResourceString(ArgumentOutOfRange_NeedNonNegNum), "Top", Top)
    
    With GetBufferInfo
        If Left + (.srWindow.Right - .srWindow.Left + 1) > .dwSize.x Then _
            Throw Cor.NewArgumentOutOfRangeException("Cannot move window outside of buffer size.", "Left", Left)
        If Top + (.srWindow.Bottom - .srWindow.Top + 1) > .dwSize.y Then _
            Throw Cor.NewArgumentOutOfRangeException("Cannot move window outside of buffer size.", "Top", Top)
        
        Dim NewPosition As SMALL_RECT
        NewPosition.Left = Left
        NewPosition.Top = Top
        With .srWindow
            NewPosition.Right = Left + (.Right - .Left)
            NewPosition.Bottom = Top + (.Bottom - .Top)
        End With
        If SetConsoleWindowInfo(mOutputHandle, True, NewPosition) = BOOL_FALSE Then IOError Err.LastDllError
    End With
End Sub

''
' Sets the size of the underlying screen buffer.
'
' @param Width The width in characters of the buffer.
' @param height The height in characters of the buffer.
'
Public Sub SetBufferSize(ByVal Width As Long, ByVal Height As Long)
    If Width < 1 Or Width > MAX_WINDOW_SIZE Then _
        Throw Cor.NewArgumentOutOfRangeException("Width must be between 1 and 32767.", "Width", Width)
    If Height < 1 Or Height > MAX_WINDOW_SIZE Then _
        Throw Cor.NewArgumentOutOfRangeException("Height must be between 1 and 32767.", "Height", Height)
    
    With GetBufferInfo.srWindow
        If Width < .Right - .Left + 1 Then _
            Throw Cor.NewArgumentOutOfRangeException("Width must reach the right side of the current window.", "Width", Width)
        If Height < .Bottom - .Top + 1 Then _
            Throw Cor.NewArgumentOutOfRangeException("Height must reach the bottom of the current window.", "Height", Height)
    End With
    
    Dim NewSize As COORD
    With NewSize
        .x = Width
        .y = Height
    End With
    If SetConsoleScreenBufferSize(mOutputHandle, ByVal AsLong(NewSize)) = BOOL_FALSE Then IOError Err.LastDllError
End Sub

''
' Returns the current width of the underlying screen buffer in characters.
'
' @return The width of the screen buffer.
'
Public Property Get BufferWidth() As Long
    BufferWidth = GetBufferInfo.dwSize.x
End Property

''
' Sets the width of the underlying screen buffer in characters.
'
' @param RHS The new width of the screen buffer.
'
Public Property Let BufferWidth(ByVal RHS As Long)
    Call SetBufferSize(RHS, BufferHeight)
End Property

''
' Returns the current height of the underlying screen buffer in characters.
'
' @return The height of the screen buffer.
'
Public Property Get BufferHeight() As Long
    BufferHeight = GetBufferInfo.dwSize.y
End Property

''
' Sets the height of the underlying screen buffer in characters.
'
' @param RHS The new height of the screen buffer.
'
Public Property Let BufferHeight(ByVal RHS As Long)
    Call SetBufferSize(BufferWidth, RHS)
End Property

''
' Returns the left coordinate of the console window within the screen buffer
' in character columns.
'
' @return The console window left coordinate in character columns.
' @remarks The underlying screen buffer can be larger than the console
' window itself. In order to see other portions of the screen buffer, the
' window must scroll around the buffer. If the screen buffer is wider than
' the window itself, then the window must be scrolled horizontally to view
' the screen buffer.
'
Public Property Get WindowLeft() As Long
    WindowLeft = GetBufferInfo.srWindow.Left
End Property

''
' Sets the left coordinate of the console window within the screen buffer
' in character columns.
'
' @param RHS The new left position.
' @remarks The view window maitains the original size.
'
Public Property Let WindowLeft(ByVal RHS As Long)
    Call SetWindowPosition(RHS, WindowTop)
End Property

''
' Returns the top of the viewable window within the screen buffer.
'
' @return The top coordinate of the window.