console.cls

VB 加密----------能够加密解密控件

        .Left = SourceLeft
        .Right = SourceLeft + SourceWidth - 1
        .Top = SourceTop
        .Bottom = SourceTop + SourceHeight - 1
    End With
    If ReadConsoleOutput(mOutputHandle, Buffer(0), ByVal AsLong(BufferSize), ByVal 0&, Region) = BOOL_FALSE Then IOError Err.LastDllError
    
    Call InternalFillArea(SourceLeft, SourceTop, SourceWidth, SourceHeight, SourceChar, SourceForeColor, SourceBackColor)
    
    With Region
        .Left = TargetLeft
        .Right = TargetLeft + SourceWidth - 1
        .Top = TargetTop
        .Bottom = TargetTop + SourceHeight - 1
    End With
    If WriteConsoleOutput(mOutputHandle, Buffer(0), ByVal AsLong(BufferSize), ByVal 0&, Region) = BOOL_FALSE Then IOError Err.LastDllError
End Sub

''
' Fills a specified region in the screen buffer with a character and color attributes.
'
' @param Left The left position in the screen buffer to start filling from.
' @param Top The top position in the screen buffer to start filling from.
' @param Width The width of the area to be filled.
' @param Height The height of the area to be filled.
' @param FillChar The character to fill the area with.
' @param ForeColor The color of the fill character.
' @param BackColor The color of the background behind the fill character.
'
Public Sub FillBufferArea(ByVal Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long, Optional ByVal FillChar As Variant = " ", Optional ByVal Forecolor As ConsoleColor = ConsoleColor.CurrentColor, Optional ByVal BackColor As ConsoleColor = ConsoleColor.CurrentColor)
    With GetBufferInfo.dwSize
        If Left < 0 Or Left >= .x Then _
            Throw Cor.NewArgumentOutOfRangeException(Environment.GetResourceString(ArgumentOutOfRange_OutsideConsoleBoundry), "Left", Left)
        If Top < 0 Or Top >= .y Then _
            Throw Cor.NewArgumentOutOfRangeException(Environment.GetResourceString(ArgumentOutOfRange_OutsideConsoleBoundry), "Top", Top)
        If Width < 0 Or Width > (.x - Left) Then _
            Throw Cor.NewArgumentOutOfRangeException(Environment.GetResourceString(ArgumentOutOfRange_OutsideConsoleBoundry), "Width", Width)
        If Width < 0 Or Width > (.y - Top) Then _
            Throw Cor.NewArgumentOutOfRangeException(Environment.GetResourceString(ArgumentOutOfRange_OutsideConsoleBoundry), "Height", Height)
    End With

    Call InternalFillArea(Left, Top, Width, Height, FillChar, Forecolor, BackColor)
End Sub

''
' Clears a specificed region in the screen buffer.
'
' @param Left The left position in the screen buffer to start clearing from.
' @param Top The top position in the screen buffer to start clearing from.
' @param Width The width of the area to be cleared.
' @param Height The height of the area to be cleared.
' @param ForeColor The color to set the text foreground color to in the cleared area.
' @param BackColor The color to set the text background color to in the cleared area.
'
Public Sub ClearBufferArea(ByVal Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long, Optional ByVal Forecolor As ConsoleColor = ConsoleColor.CurrentColor, Optional ByVal BackColor As ConsoleColor = ConsoleColor.CurrentColor)
    Call FillBufferArea(Left, Top, Width, Height, " ", Forecolor, BackColor)
End Sub

''
' Restores the foreground and background colors to their original values.
'
' @remarks The backcolor will be set to ConsoleColor.Black, the forecolor
' will be set to ConsoleColor.Gray.
'
Public Sub ResetColor()
    If SetConsoleTextAttribute(mOutputHandle, (GetBufferInfo.wAttributes And &HFF00) Or ConsoleColor.Gray) = BOOL_FALSE Then IOError Err.LastDllError
End Sub

''
' Returns the encoding for the current console output.
'
' @return An Encoding object for the current console output encoding.
'
Public Property Get OutputEncoding() As Encoding
    Set OutputEncoding = Encoding.GetEncoding(GetConsoleOutputCP)
End Property

''
' Sets the encoding for the console output.
'
' @param RHS The new encoding used for output to the console.
' @remarks This is only supported on Windows NT machines.
'
Public Property Set OutputEncoding(ByVal RHS As Encoding)
    If RHS Is Nothing Then _
        Throw Cor.NewArgumentNullException("Cannot set output encoding to Nothing.", "OutputEncoding")
        
    Call Environment.VerifyNTMachine
    
    If (Not mOutput Is Nothing) And (mOriginalOut = True) Then
        mOutput.Flush
        Set mOutput = Nothing
    End If
    If (Not mError Is Nothing) And (mOriginalError = True) Then
        mError.Flush
        Set mError = Nothing
    End If
    
    If SetConsoleOutputCP(RHS.CodePage) = BOOL_FALSE Then IOError Err.LastDllError
End Property

''
' Returns the encoding used for the input from the console.
'
' @return An encoding for the input from the console.
'
Public Property Get InputEncoding() As Encoding
    Set InputEncoding = Encoding.GetEncoding(GetConsoleCP)
End Property

''
' Sets the encoding used during input from the console.
'
' @param RHS The new encoding used for input from the console.
' @remarks This is only supported on Windows NT machines.
'
Public Property Set InputEncoding(ByVal RHS As Encoding)
    If RHS Is Nothing Then _
        Throw Cor.NewArgumentNullException("Cannot set input encoding to Nothing.", "InputEncoding")
        
    Call Environment.VerifyNTMachine
    
    If SetConsoleCP(RHS.CodePage) = BOOL_FALSE Then IOError Err.LastDllError
    Set mInput = Nothing
End Property

''
' Returns the state of the Caps-Lock key.
'
' @return CapsLock On = True, otherwise False.
' @remarks The CapsLock key is a toggle key, so this property
' returns the current state, not if it is currently being pressed
' or not, only if it is on or off.
'
Public Property Get CapsLock() As Boolean
    CapsLock = (GetKeyState(vbKeyCapital) And 1)
End Property

''
' Returns the state of the Num-Lock key.
' @return NumLock On = True, otherwise False.
' @remarks The NumLock key is a toggle key, so this property
' returns the current state, not if it is currently being pressed
' or not, only if it is on or off.
'
Public Property Get NumLock() As Boolean
    NumLock = (GetKeyState(vbKeyNumlock) And 1)
End Property

''
' Returns if a key has been pressed and is available to be
' read in using one of the read methods.
'
' @return Returns if a key is ready to be read in.
'
Public Property Get KeyAvailable() As Boolean
    Dim Record  As INPUT_RECORD
    Dim NumRead As Long
    
    If mKeyPressHistory.EventType = KEY_EVENT Then
        KeyAvailable = True
        Exit Property
    End If
    
    Do
        If PeekConsoleInput(mInputHandle, Record, 1, NumRead) = BOOL_FALSE Then IOError Err.LastDllError
        If NumRead = 0 Then Exit Property
        If Record.EventType = KEY_EVENT And Record.KeyEvent.bKeyDown = BOOL_TRUE Then
            KeyAvailable = True
            Exit Property
        End If
        
        ' nothing matched what we expected, so read it and discard.
        If ReadConsoleInput(mInputHandle, Record, 1, NumRead) = BOOL_FALSE Then IOError Err.LastDllError
    Loop
End Property

''
' Returns if the Control+C combination is managed by the system or returned as keyboard input.
'
' @return The state of management for Control+C.
'
Public Property Get TreatControlCAsInput() As Boolean
    Dim modes As Long
    If GetConsoleMode(mInputHandle, modes) = BOOL_FALSE Then IOError Err.LastDllError
    TreatControlCAsInput = (modes And ENABLE_PROCESSED_INPUT)
End Property

''
' Sets if the Control+C combination is managed by the system or returned as keyboard input.
'
' @param RHS Flag indicating if the system should manage Control+C or not.
'
Public Property Let TreatControlCAsInput(ByVal RHS As Boolean)
    Dim modes As Long
    If GetConsoleMode(mInputHandle, modes) = BOOL_FALSE Then IOError Err.LastDllError
    If RHS Then
        modes = modes Or ENABLE_PROCESSED_INPUT
    Else
        modes = modes And (Not ENABLE_PROCESSED_INPUT)
    End If
    If SetConsoleMode(mInputHandle, modes) = BOOL_FALSE Then IOError Err.LastDllError
End Property


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Private Helpers
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function GetConsoleStream(ByVal Handle As Long, ByVal Access As FileAccess) As Stream
    Dim Ret As New ConsoleStream
    Call Ret.Init(Handle, Access)
    Set GetConsoleStream = Ret
End Function

Private Sub InternalWrite(ByVal Value As String, ByRef args() As Variant, ByVal NewLine As Boolean)
    If Not cArray.IsNull(args) Then
        If UBound(args) >= 0 Then Value = cString.FormatArray(Value, args)
    End If
    If NewLine Then Value = Value & Out.NewLine
    Call Out.WriteValue(Value)
End Sub

Private Sub InternalWriteLine(ByRef args() As Variant)
    Dim ub  As Long
    Dim s   As String
    
    ub = UBound(args)
    
    If ub >= 0 Then s = Convert.ToString(args(0))
    If ub > 0 Then
        Dim i As Long
        For i = 1 To ub
            Call Helper.MoveVariant(args(i - 1), args(i))
        Next i
    Else
        Erase args
    End If
    
    Call InternalWrite(s, args, True)
End Sub

Private Sub InternalWriteValue(ByRef Value As Variant, ByRef args() As Variant)
    InternalWrite Convert.ToString(Value), args, False
End Sub

Private Sub Init()
    mOwnsConsole = (AllocConsole <> BOOL_FALSE)
    Call Sleep(10)     ' give it time to be created
    Call SetConsoleCtrlHandler(AddressOf ControlBreakHandler, True)
    mOutputHandle = GetStdHandle(STD_OUTPUT_HANDLE)
    mInputHandle = GetStdHandle(STD_INPUT_HANDLE)
    mErrorHandle = GetStdHandle(STD_ERROR_HANDLE)
    mKeyPressHistory.EventType = NO_EVENT
    mOriginalOut = True
    mOriginalError = True
End Sub

Private Function GetBufferInfo() As CONSOLE_SCREEN_BUFFER_INFO
    If GetConsoleScreenBufferInfo(mOutputHandle, GetBufferInfo) = BOOL_FALSE Then IOError Err.LastDllError
End Function

Private Function GetCursorInfo() As CONSOLE_CURSOR_INFO
    If GetConsoleCursorInfo(mOutputHandle, GetCursorInfo) = BOOL_FALSE Then IOError Err.LastDllError
End Function

Private Function InternalReadKey(ByRef RetVal As ConsoleKeyInfo) As Boolean
    Const ALT_KEYS As Long = 3
    Const SHIFT_KEYS As Long = 16
    Const CTRL_KEYS As Long = 12
    
    If mKeyPressHistory.EventType <> KEY_EVENT Then Exit Function
    
    With mKeyPressHistory.KeyEvent
        .wRepeatCount = .wRepeatCount - 1
        If .wRepeatCount = 0 Then mKeyPressHistory.EventType = NO_EVENT
        Set RetVal = Cor.NewConsoleKeyInfo(.uChar, .wVirtualKeyCode, .dwControlKeyState And SHIFT_KEYS, .dwControlKeyState And ALT_KEYS, .dwControlKeyState And CTRL_KEYS)
    End With
    
    InternalReadKey = True
End Function

Private Sub InternalFillArea(ByVal Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long, ByRef FillChar As Variant, ByVal Forecolor As ConsoleColor, ByVal BackColor As ConsoleColor)
    
    Select Case Forecolor
        Case ConsoleColor.CurrentColor: Forecolor = ForegroundColor
        Case Is < 0, Is > 15
            Throw Cor.NewArgumentOutOfRangeException("Invalid Console Color value.", "ForeColor", Forecolor)
    End Select

    Select Case BackColor
        Case ConsoleColor.CurrentColor: BackColor = BackgroundColor
        Case Is < 0, Is > 15
            Throw Cor.NewArgumentOutOfRangeException("Invalid Console Color value.", "BackColor", BackColor)
    End Select
    
    If Width = 0 Or Height = 0 Then Exit Sub
    
    Dim FillByte As Byte
    Select Case VarType(FillChar)
        Case vbString
            If Len(FillChar) = 0 Then Exit Sub
            FillByte = Asc(FillChar)
        
        Case vbLong, vbInteger, vbByte:     FillByte = FillChar
        Case Else
            Throw Cor.NewArgumentException("Invalid fill Character", "FillChar")
    End Select

    If Len(FillChar) > 0 Then
        Dim TextColor As Long
        TextColor = (BackColor * &H10) Or Forecolor
        
        Dim ClearCoord As COORD
        ClearCoord.x = Left
        
        Dim i As Long
        For i = 0 To Height - 1
            ClearCoord.y = Top + i
            If FillConsoleOutputCharacter(mOutputHandle, FillByte, Width, ByVal AsLong(ClearCoord), 0) = BOOL_FALSE Then IOError Err.LastDllError
            If FillConsoleOutputAttribute(mOutputHandle, TextColor, Width, ByVal AsLong(ClearCoord), 0) = BOOL_FALSE Then IOError Err.LastDllError
        Next i
    End If
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Class Events
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
    Call Init
End Sub

Private Sub Class_Terminate()
    Call SetConsoleCtrlHandler(AddressOf ControlBreakHandler, False)
    If mOwnsConsole Then Call FreeConsole
End Sub