'Classes/System/Console.ab Namespace System Enum ConsoleColor Black = 0 DarkGray = FOREGROUND_INTENSITY Gray = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE White = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY DarkRed = FOREGROUND_RED Red = FOREGROUND_RED Or FOREGROUND_INTENSITY DarkYellow = FOREGROUND_RED Or FOREGROUND_GREEN Yellow = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY DarkGreen = FOREGROUND_GREEN Green = FOREGROUND_GREEN Or FOREGROUND_INTENSITY DarkCyan = FOREGROUND_GREEN Or FOREGROUND_BLUE Cyan = FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY DarkBlue = FOREGROUND_BLUE Blue = FOREGROUND_BLUE Or FOREGROUND_INTENSITY DarkMagenta = FOREGROUND_RED Or FOREGROUND_BLUE Magenta = FOREGROUND_RED Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY End Enum /* @brief コンソール入出力・ウィンドウなどのクラス @date 2008/02/26 @auther Egtra */ Class Console Public /* @brief コンソールの背景色を取得または設定する @date 2008/09/02 @auther NoWest */ Static Sub BackgroundColor ( value As ConsoleColor ) If ActiveBasic.IsNothing(Console.out) Then Exit Sub Else If Console.hconsoleout = NULL Then Exit Sub Else Dim csbi As CONSOLE_SCREEN_BUFFER_INFO Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi) If ret = 0 Then Throw New IO.IOException() csbi.wAttributes And = &HFF0F'背景色だけ変更できるようにマスク処理 ret = SetConsoleTextAttribute(Console.hconsoleout,csbi.wAttributes Or (This.ConsoleColorToTextAttribute(value)<<4) As Word/* foreをbackへ変換 */) If ret = 0 Then Throw New IO.IOException() End If End If End Sub Static Function BackgroundColor() As ConsoleColor If ActiveBasic.IsNothing(Console.out) Then Return ConsoleColor.Gray Else If Console.hconsoleout = NULL Then Return ConsoleColor.Gray Else Dim csbi As CONSOLE_SCREEN_BUFFER_INFO Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi) If ret = 0 Then Throw New IO.IOException() Dim attributes = csbi.wAttributes And &H00F0'背景色だけ取り出せるようにマスク処理 Return This.TextAttributeToConsoleColor(attributes>>4/* backをforeへ変換 */) End If End If End Function /* @brief バッファ領域の高さを取得または設定する @date 2008/09/02 @auther NoWest */ Static Sub BufferHeight ( value As Long ) Dim width As Long, height As Long This.GetBufferSize(width,height) Console.SetBufferSize(width,value) End Sub Static Function BufferHeight () As Long Dim width As Long, height As Long This.GetBufferSize(width,height) Return height End Function /* @brief バッファ領域の幅を取得または設定する @date 2008/09/02 @auther NoWest */ Static Sub BufferWidth ( value As Long ) Dim width As Long, height As Long This.GetBufferSize(width,height) Console.SetBufferSize(value,height) End Sub Static Function BufferWidth () As Long Dim width As Long, height As Long This.GetBufferSize(width,height) Return width End Function /* @brief カーソルの列位置を取得または設定する @date 2008/09/02 @auther NoWest */ Static Sub CursorLeft ( value As Long ) Dim left As Long, top As Long This.GetCursorPosition(left,top) Console.SetCursorPosition(value,top) End Sub Static Function CursorLeft () As Long Dim left As Long, top As Long This.GetCursorPosition(left,top) Return left End Function /* @brief 文字セル内のカーソルの高さを取得または設定する @date 2008/09/02 @auther NoWest */ Static Sub CursorSize ( value As Long ) If Console.hconsoleout = NULL Then Exit Sub Else Dim cci As CONSOLE_CURSOR_INFO Dim ret = GetConsoleCursorInfo(Console.hconsoleout,cci) If ret = 0 Then Throw New IO.IOException() cci.dwSize = value As DWord ret = SetConsoleCursorInfo(Console.hconsoleout,cci) If ret = 0 Then Throw New IO.IOException() End If End Sub Static Function CursorSize () As Long If Console.hconsoleout = NULL Then Return -1 As Long Else Dim cci As CONSOLE_CURSOR_INFO Dim ret = GetConsoleCursorInfo(Console.hconsoleout,cci) If ret = 0 Then Throw New IO.IOException() Return cci.dwSize As Long End If End Function /* @brief カーソルの行位置を取得または設定する @date 2008/09/02 @auther NoWest */ Static Sub CursorTop ( value As Long ) Dim left As Long, top As Long This.GetCursorPosition(left,top) Console.SetCursorPosition(left,value) End Sub Static Function CursorTop () As Long Dim left As Long, top As Long This.GetCursorPosition(left,top) Return top End Function /* @brief カーソルを表示するかどうかを示す値を取得または設定する @date 2008/09/02 @auther NoWest */ Static Sub CursorVisible ( visible As Boolean ) If Console.hconsoleout = NULL Then Exit Sub Else Dim cci As CONSOLE_CURSOR_INFO Dim ret = GetConsoleCursorInfo(Console.hconsoleout,cci) If ret = 0 Then Throw New IO.IOException() cci.bVisible = visible As BOOL ret = SetConsoleCursorInfo(Console.hconsoleout,cci) If ret = 0 Then Throw New IO.IOException() End If End Sub Static Function CursorVisible () As Boolean If Console.hconsoleout = NULL Then Return False Else Dim cci As CONSOLE_CURSOR_INFO Dim ret = GetConsoleCursorInfo(Console.hconsoleout,cci) If ret = 0 Then Throw New IO.IOException() Return cci.bVisible As Boolean End If End Function /* @brief コンソールの前景色を取得または設定する @date 2008/09/02 @auther NoWest */ Static Sub ForegroundColor ( value As ConsoleColor ) If ActiveBasic.IsNothing(Console.out) Then Exit Sub Else If Console.hconsoleout = NULL Then Exit Sub Else Dim csbi As CONSOLE_SCREEN_BUFFER_INFO Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi) If ret = 0 Then Throw New IO.IOException() csbi.wAttributes And = &HFFF0'前景色だけ変更できるようにマスク処理 ret = SetConsoleTextAttribute(Console.hconsoleout,csbi.wAttributes Or This.ConsoleColorToTextAttribute(value)) If ret = 0 Then Throw New IO.IOException() End If End If End Sub Static Function ForegroundColor() As ConsoleColor If ActiveBasic.IsNothing(Console.out) Then Return ConsoleColor.Gray Else If Console.hconsoleout = NULL Then Return ConsoleColor.Gray Else Dim csbi As CONSOLE_SCREEN_BUFFER_INFO Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi) If ret = 0 Then Throw New IO.IOException() Dim attributes = csbi.wAttributes And &H000F'前景色だけ取り出せるようにマスク処理 Return This.TextAttributeToConsoleColor(attributes) End If End If End Function /* @brief コンソールのタイトルを取得または設定する @date 2008/09/02 @auther NoWest */ Static Sub Title( title As String ) If Console.hconsoleout =NULL Then Exit Sub Else SetConsoleTitle(ToTCStr(title)) End If End Sub Static Function Title() As String If Console.hconsoleout =NULL Then Return "" Else Dim sb = New Text.StringBuilder sb.Length = 24500 Dim ret = GetConsoleTitle(StrPtr(sb),sb.Length()) If ret = 0 Then Dim error = GetLastError() If error <> ERROR_SUCSESS Then ActiveBasic.Windows.ThrowWithErrorCode(error, "Console.Title") End If End If sb.Length = ret Return sb.ToString() End If End Function /* @brief 標準エラー出力を設定する @date 2008/08/21 @auther Egtra */ Static Sub SetError(newErr As IO.TextWriter) If ActiveBasic.IsNothing(newErr) Then Throw New ArgumentNullException("newErr") End If Console.err = newErr Dim sw = Console.err As IO.StreamWriter Dim fs = sw.BaseStream() As IO.FileStream Console.hconsoleerr = fs.Handle() End Sub /* @brief 標準エラー出力を取得する @date 2008/08/21 @auther Egtra */ Static Function Error() As IO.TextWriter Error = err End Function /* @brief 標準出力を設定する @date 2008/06/21 @auther overtaker */ Static Sub SetOut(newOut As IO.TextWriter) If ActiveBasic.IsNothing(newOut) Then Throw New ArgumentNullException("newOut") End If Console.out = newOut Dim sw = Console.out As IO.StreamWriter Dim fs = sw.BaseStream() As IO.FileStream Console.hconsoleout = fs.Handle() End Sub /* @brief 標準出力を取得する @date 2008/06/21 @auther overtaker */ Static Function Out() As IO.TextWriter Out = out End Function /* @brief 標準出力に1行書き込む @date 2008/06/21 @auther overtaker */ Static Sub WriteLine(value As String) out.WriteLine(value) out.Flush() End Sub Static Sub WriteLine() out.WriteLine() out.Flush() End Sub Static Sub WriteLine(x As Boolean) WriteLine(Str$(x)) End Sub Static Sub WriteLine(x As Char) WriteLine(Chr$(x)) End Sub Static Sub WriteLine(x As Byte) WriteLine(Str$(x)) End Sub #ifdef UNICODE Static Sub WriteLine(x As SByte) WriteLine(Str$(x)) End Sub #else Static Sub WriteLine(x As Word) WriteLine(Str$(x)) End Sub #endif Static Sub WriteLine(x As Integer) WriteLine(Str$(x)) End Sub Static Sub WriteLine(x As DWord) WriteLine(Str$(x)) End Sub Static Sub WriteLine(x As Long) WriteLine(Str$(x)) End Sub Static Sub WriteLine(x As QWord) WriteLine(Str$(x)) End Sub Static Sub WriteLine(x As Int64) WriteLine(Str$(x)) End Sub Static Sub WriteLine(x As Single) WriteLine(Str$(x)) End Sub Static Sub WriteLine(x As Double) WriteLine(Str$(x)) End Sub Static Sub WriteLine(x As Object) WriteLine(x.ToString) End Sub /* @brief 標準出力に書き込む @date 2008/06/21 @auther overtaker */ Static Sub Write(s As String) out.Write(s) out.Flush() End Sub Static Sub Write(x As Boolean) Write(Str$(x)) End Sub Static Sub Write(x As Char) Write(Chr$(x)) End Sub Static Sub Write(x As Byte) Write(Str$(x)) End Sub #ifdef UNICODE Static Sub Write(x As SByte) Write(Str$(x)) End Sub #else Static Sub Write(x As Word) Write(Str$(x)) End Sub #endif Static Sub Write(x As Integer) Write(Str$(x)) End Sub Static Sub Write(x As DWord) Write(Str$(x)) End Sub Static Sub Write(x As Long) Write(Str$(x)) End Sub Static Sub Write(x As QWord) Write(Str$(x)) End Sub Static Sub Write(x As Int64) Write(Str$(x)) End Sub Static Sub Write(x As Object) Write(x.ToString) End Sub /* @brief 標準入力を設定する @date 2008/02/26 @auther Egtra */ Static Sub SetIn(newIn As IO.TextReader) If ActiveBasic.IsNothing(newIn) Then Throw New ArgumentNullException("newIn") End If Console.in = newIn Dim sr = Console.in As IO.StreamReader Dim fs = sr.BaseStream() As IO.FileStream Console.hconsolein = fs.Handle() End Sub /* @brief 標準入力を取得する @date 2008/02/26 @auther Egtra */ Static Function In() As IO.TextReader In = in End Function /* @brief 標準入力から1行読み込む @date 2008/02/26 @auther Egtra */ Static Function ReadLine() As String ReadLine = in.ReadLine() End Function /* @brief 標準入力から1行読み込む @date 2008/02/26 @auther Egtra */ Static Function Read() As Long Read = in.Read() End Function /* @brief コンソール バッファおよび対応するコンソール ウィンドウをクリア @date 2008/09/02 @auther NoWest */ Static Sub Clear() If Console.hconsoleout = NULL Then Exit Sub Else Dim csbi As CONSOLE_SCREEN_BUFFER_INFO Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi) If ret = 0 Then Throw New IO.IOException() Dim length = csbi.dwSize.X * csbi.dwSize.Y Dim written As DWord Dim s = New String(" ") ret = FillConsoleOutputCharacter(Console.hconsoleout,s[0],length,0,written) If ret = 0 Then Throw New IO.IOException() ret = FillConsoleOutputAttribute(Console.hconsoleout,csbi.wAttributes,length,0,written) If ret = 0 Then Throw New IO.IOException() ret = SetConsoleCursorPosition(Console.hconsoleout,0) If ret = 0 Then Throw New IO.IOException() End If End Sub /* @brief 標準エラー ストリームを取得 @date 2008/09/07 @auther NoWest */ Static Sub OpenStandardError() Console.SetError(System.IO.TextWriter.Synchronized(New System.IO.StreamWriter(New System.IO.FileStream(GetStdHandle(STD_ERROR_HANDLE), System.IO.FileAccess.Write, False)))) End Sub /* @brief 標準入力ストリーム ストリームを取得 @date 2008/09/07 @auther NoWest */ Static Sub OpenStandardInput() Console.SetIn(System.IO.TextReader.Synchronized(New System.IO.StreamReader(New System.IO.FileStream(GetStdHandle(STD_INPUT_HANDLE), System.IO.FileAccess.Read, False)))) End Sub /* @brief 標準出力ストリーム ストリームを取得 @date 2008/09/07 @auther NoWest */ Static Sub OpenStandardOutput() Console.SetOut(System.IO.TextWriter.Synchronized(New System.IO.StreamWriter(New System.IO.FileStream(GetStdHandle(STD_OUTPUT_HANDLE), System.IO.FileAccess.Write, False)))) End Sub /* @brief コンソールの前景色および背景色を既定値に設定(前景色=gray 背景色=black) @date 2008/09/07 @auther NoWest */ Static Sub ResetColor() Console.BackgroundColor(ConsoleColor.Black) Console.ForegroundColor(ConsoleColor.Gray) End Sub /* @brief バッファ領域の高さと幅を指定された値に設定 @date 2008/09/02 @auther NoWest */ Static Sub SetBufferSize ( width As Long, height As Long ) If Console.hconsoleout = NULL Then Exit Sub Else Dim size As COORD size.X = width As Integer size.Y = height As Integer Dim ret = SetConsoleScreenBufferSize(Console.hconsoleout,COORDtoDWORD(size)) If ret = 0 Then Throw New IO.IOException() End If End Sub /* @brief カーソルの位置を設定 @date 2008/09/02 @auther NoWest */ Static Sub SetCursorPosition ( left As Long, top As Long ) If Console.hconsoleout = NULL Then Exit Sub Else Dim pos As COORD pos.X = left As Integer pos.Y = top As Integer Dim ret = SetConsoleCursorPosition(Console.hconsoleout,COORDtoDWORD(pos)) If ret = 0 Then Throw New IO.IOException() End If End Sub Private Function enter() As ActiveBasic.Windows.CriticalSectionLock Imports ActiveBasic.Windows If ActiveBasic.IsNothing(cs) Then Dim lock = New CriticalSectionLock(_System_CriticalSection) Try If ActiveBasic.IsNothing(cs) Then cs = New CriticalSection End If Finally lock.Dispose() End Try End If enter = cs.Enter End Function Function ConsoleColorToTextAttribute( value As ConsoleColor ) As Word Dim ret = value As DWord Return ret As Word End Function Function TextAttributeToConsoleColor( value As Word ) As ConsoleColor Select Case value Case 0 Return ConsoleColor.Black Case FOREGROUND_INTENSITY Return ConsoleColor.DarkGray Case FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE Return ConsoleColor.Gray Case FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY Return ConsoleColor.White Case FOREGROUND_RED Return ConsoleColor.DarkRed Case FOREGROUND_RED Or FOREGROUND_INTENSITY Return ConsoleColor.Red Case FOREGROUND_RED Or FOREGROUND_GREEN Return ConsoleColor.DarkYellow Case FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY Return ConsoleColor.Yellow Case FOREGROUND_GREEN Return ConsoleColor.DarkGreen Case FOREGROUND_GREEN Or FOREGROUND_INTENSITY Return ConsoleColor.Green Case FOREGROUND_GREEN Or FOREGROUND_BLUE Return ConsoleColor.DarkCyan Case FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY Return ConsoleColor.Cyan Case FOREGROUND_BLUE Return ConsoleColor.DarkBlue Case FOREGROUND_BLUE Or FOREGROUND_INTENSITY Return ConsoleColor.Blue Case FOREGROUND_RED Or FOREGROUND_BLUE Return ConsoleColor.DarkMagenta Case FOREGROUND_RED Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY Return ConsoleColor.Magenta Case Else Return ConsoleColor.Gray End Select End Function Sub GetCursorPosition ( ByRef left As Long, ByRef top As Long ) If Console.hconsoleout = NULL Then Exit Sub Else Dim csbi As CONSOLE_SCREEN_BUFFER_INFO Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi) If ret = 0 Then Throw New IO.IOException() left = csbi.dwCursorPosition.X top = csbi.dwCursorPosition.Y End If End Sub Sub GetBufferSize ( ByRef width As Long, ByRef height As Long ) If Console.hconsoleout = NULL Then Exit Sub Else Dim csbi As CONSOLE_SCREEN_BUFFER_INFO Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi) If ret = 0 Then Throw New IO.IOException() width = csbi.dwSize.X height = csbi.dwSize.Y End If End Sub Static hconsoleerr = NULL As HANDLE Static hconsolein = NULL As HANDLE Static hconsoleout = NULL As HANDLE Static in = Nothing As IO.TextReader Static out = Nothing As IO.TextWriter Static err = Nothing As IO.TextWriter Static cs = Nothing As ActiveBasic.Windows.CriticalSection End Class End Namespace 'System