From: cts@kampong.aedinc.net ((null))
Subject: Re: more specific
Date: 2000/08/26
Date: 2000-08-26T00:00:00+00:00 [thread overview]
Message-ID: <x9Xp5.4201$_X.14926@newsfeed.slurp.net> (raw)
In-Reply-To: 39a7ed56$0$20400@echo-01.iinet.net.au
In article <39a7ed56$0$20400@echo-01.iinet.net.au>,
Damon Carter <vins@iinet.net.au> wrote:
>Im writing a program using ada95 compiler thats going to run in a dos
>window,
>and i want to change the dos window colour from black to blue.. i am
>using windows 95 and have 32bit video card.. i think
>
>Damon, Carter
You'll want to get Jerry van Dijk's NT_Console package. I'm not sure where
his web page went, so I'm just tacking an old version onto this message.
If you can find his home page, I'm sure he has newer version.
>---cut here---<
-----------------------------------------------------------------------
--
-- File: nt_console.ads
-- Description: Win95/NT console support
-- Rev: 0.1
-- Date: 18-jan-1998
-- Author: Jerry van Dijk
-- Mail: jdijk@acm.org
--
-- Copyright (c) Jerry van Dijk, 1997, 1998
-- Billie Holidaystraat 28
-- 2324 LK LEIDEN
-- THE NETHERLANDS
-- tel int + 31 71 531 43 65
--
-- Permission granted to use for any purpose, provided this copyright
-- remains attached and unmodified.
--
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
--
-----------------------------------------------------------------------
package NT_Console is
----------------------
-- TYPE DEFINITIONS --
----------------------
subtype X_Pos is Natural range 0 .. 79;
subtype Y_Pos is Natural range 0 .. 24;
type Color_Type is (Black, Blue, Green, Cyan, Red, Magenta, Brown, Gray,
Light_Blue, Light_Green, Light_Cyan, Light_Red,
Light_Magenta, Yellow, White);
----------------------
-- EXTENDED PC KEYS --
----------------------
Key_Alt_Escape : constant Character := Character'Val (16#01#);
Key_Control_At : constant Character := Character'Val (16#03#);
Key_Alt_Backspace : constant Character := Character'Val (16#0E#);
Key_BackTab : constant Character := Character'Val (16#0F#);
Key_Alt_Q : constant Character := Character'Val (16#10#);
Key_Alt_W : constant Character := Character'Val (16#11#);
Key_Alt_E : constant Character := Character'Val (16#12#);
Key_Alt_R : constant Character := Character'Val (16#13#);
Key_Alt_T : constant Character := Character'Val (16#14#);
Key_Alt_Y : constant Character := Character'Val (16#15#);
Key_Alt_U : constant Character := Character'Val (16#16#);
Key_Alt_I : constant Character := Character'Val (16#17#);
Key_Alt_O : constant Character := Character'Val (16#18#);
Key_Alt_P : constant Character := Character'Val (16#19#);
Key_Alt_LBracket : constant Character := Character'Val (16#1A#);
Key_Alt_RBracket : constant Character := Character'Val (16#1B#);
Key_Alt_Return : constant Character := Character'Val (16#1C#);
Key_Alt_A : constant Character := Character'Val (16#1E#);
Key_Alt_S : constant Character := Character'Val (16#1F#);
Key_Alt_D : constant Character := Character'Val (16#20#);
Key_Alt_F : constant Character := Character'Val (16#21#);
Key_Alt_G : constant Character := Character'Val (16#22#);
Key_Alt_H : constant Character := Character'Val (16#23#);
Key_Alt_J : constant Character := Character'Val (16#24#);
Key_Alt_K : constant Character := Character'Val (16#25#);
Key_Alt_L : constant Character := Character'Val (16#26#);
Key_Alt_Semicolon : constant Character := Character'Val (16#27#);
Key_Alt_Quote : constant Character := Character'Val (16#28#);
Key_Alt_Backquote : constant Character := Character'Val (16#29#);
Key_Alt_Backslash : constant Character := Character'Val (16#2B#);
Key_Alt_Z : constant Character := Character'Val (16#2C#);
Key_Alt_X : constant Character := Character'Val (16#2D#);
Key_Alt_C : constant Character := Character'Val (16#2E#);
Key_Alt_V : constant Character := Character'Val (16#2F#);
Key_Alt_B : constant Character := Character'Val (16#30#);
Key_Alt_N : constant Character := Character'Val (16#31#);
Key_Alt_M : constant Character := Character'Val (16#32#);
Key_Alt_Comma : constant Character := Character'Val (16#33#);
Key_Alt_Period : constant Character := Character'Val (16#34#);
Key_Alt_Slash : constant Character := Character'Val (16#35#);
Key_Alt_KPStar : constant Character := Character'Val (16#37#);
Key_F1 : constant Character := Character'Val (16#3B#);
Key_F2 : constant Character := Character'Val (16#3C#);
Key_F3 : constant Character := Character'Val (16#3D#);
Key_F4 : constant Character := Character'Val (16#3E#);
Key_F5 : constant Character := Character'Val (16#3F#);
Key_F6 : constant Character := Character'Val (16#40#);
Key_F7 : constant Character := Character'Val (16#41#);
Key_F8 : constant Character := Character'Val (16#42#);
Key_F9 : constant Character := Character'Val (16#43#);
Key_F10 : constant Character := Character'Val (16#44#);
Key_Home : constant Character := Character'Val (16#47#);
Key_Up : constant Character := Character'Val (16#48#);
Key_PageUp : constant Character := Character'Val (16#49#);
Key_Alt_KPMinus : constant Character := Character'Val (16#4A#);
Key_Left : constant Character := Character'Val (16#4B#);
Key_Center : constant Character := Character'Val (16#4C#);
Key_Right : constant Character := Character'Val (16#4D#);
Key_Alt_KPPlus : constant Character := Character'Val (16#4E#);
Key_End : constant Character := Character'Val (16#4F#);
Key_Down : constant Character := Character'Val (16#50#);
Key_PageDown : constant Character := Character'Val (16#51#);
Key_Insert : constant Character := Character'Val (16#52#);
Key_Delete : constant Character := Character'Val (16#53#);
Key_Shift_F1 : constant Character := Character'Val (16#54#);
Key_Shift_F2 : constant Character := Character'Val (16#55#);
Key_Shift_F3 : constant Character := Character'Val (16#56#);
Key_Shift_F4 : constant Character := Character'Val (16#57#);
Key_Shift_F5 : constant Character := Character'Val (16#58#);
Key_Shift_F6 : constant Character := Character'Val (16#59#);
Key_Shift_F7 : constant Character := Character'Val (16#5A#);
Key_Shift_F8 : constant Character := Character'Val (16#5B#);
Key_Shift_F9 : constant Character := Character'Val (16#5C#);
Key_Shift_F10 : constant Character := Character'Val (16#5D#);
Key_Control_F1 : constant Character := Character'Val (16#5E#);
Key_Control_F2 : constant Character := Character'Val (16#5F#);
Key_Control_F3 : constant Character := Character'Val (16#60#);
Key_Control_F4 : constant Character := Character'Val (16#61#);
Key_Control_F5 : constant Character := Character'Val (16#62#);
Key_Control_F6 : constant Character := Character'Val (16#63#);
Key_Control_F7 : constant Character := Character'Val (16#64#);
Key_Control_F8 : constant Character := Character'Val (16#65#);
Key_Control_F9 : constant Character := Character'Val (16#66#);
Key_Control_F10 : constant Character := Character'Val (16#67#);
Key_Alt_F1 : constant Character := Character'Val (16#68#);
Key_Alt_F2 : constant Character := Character'Val (16#69#);
Key_Alt_F3 : constant Character := Character'Val (16#6A#);
Key_Alt_F4 : constant Character := Character'Val (16#6B#);
Key_Alt_F5 : constant Character := Character'Val (16#6C#);
Key_Alt_F6 : constant Character := Character'Val (16#6D#);
Key_Alt_F7 : constant Character := Character'Val (16#6E#);
Key_Alt_F8 : constant Character := Character'Val (16#6F#);
Key_Alt_F9 : constant Character := Character'Val (16#70#);
Key_Alt_F10 : constant Character := Character'Val (16#71#);
Key_Control_Left : constant Character := Character'Val (16#73#);
Key_Control_Right : constant Character := Character'Val (16#74#);
Key_Control_End : constant Character := Character'Val (16#75#);
Key_Control_PageDown : constant Character := Character'Val (16#76#);
Key_Control_Home : constant Character := Character'Val (16#77#);
Key_Alt_1 : constant Character := Character'Val (16#78#);
Key_Alt_2 : constant Character := Character'Val (16#79#);
Key_Alt_3 : constant Character := Character'Val (16#7A#);
Key_Alt_4 : constant Character := Character'Val (16#7B#);
Key_Alt_5 : constant Character := Character'Val (16#7C#);
Key_Alt_6 : constant Character := Character'Val (16#7D#);
Key_Alt_7 : constant Character := Character'Val (16#7E#);
Key_Alt_8 : constant Character := Character'Val (16#7F#);
Key_Alt_9 : constant Character := Character'Val (16#80#);
Key_Alt_0 : constant Character := Character'Val (16#81#);
Key_Alt_Dash : constant Character := Character'Val (16#82#);
Key_Alt_Equals : constant Character := Character'Val (16#83#);
Key_Control_PageUp : constant Character := Character'Val (16#84#);
Key_F11 : constant Character := Character'Val (16#85#);
Key_F12 : constant Character := Character'Val (16#86#);
Key_Shift_F11 : constant Character := Character'Val (16#87#);
Key_Shift_F12 : constant Character := Character'Val (16#88#);
Key_Control_F11 : constant Character := Character'Val (16#89#);
Key_Control_F12 : constant Character := Character'Val (16#8A#);
Key_Alt_F11 : constant Character := Character'Val (16#8B#);
Key_Alt_F12 : constant Character := Character'Val (16#8C#);
Key_Control_Up : constant Character := Character'Val (16#8D#);
Key_Control_KPDash : constant Character := Character'Val (16#8E#);
Key_Control_Center : constant Character := Character'Val (16#8F#);
Key_Control_KPPlus : constant Character := Character'Val (16#90#);
Key_Control_Down : constant Character := Character'Val (16#91#);
Key_Control_Insert : constant Character := Character'Val (16#92#);
Key_Control_Delete : constant Character := Character'Val (16#93#);
Key_Control_KPSlash : constant Character := Character'Val (16#95#);
Key_Control_KPStar : constant Character := Character'Val (16#96#);
Key_Alt_EHome : constant Character := Character'Val (16#97#);
Key_Alt_EUp : constant Character := Character'Val (16#98#);
Key_Alt_EPageUp : constant Character := Character'Val (16#99#);
Key_Alt_ELeft : constant Character := Character'Val (16#9B#);
Key_Alt_ERight : constant Character := Character'Val (16#9D#);
Key_Alt_EEnd : constant Character := Character'Val (16#9F#);
Key_Alt_EDown : constant Character := Character'Val (16#A0#);
Key_Alt_EPageDown : constant Character := Character'Val (16#A1#);
Key_Alt_EInsert : constant Character := Character'Val (16#A2#);
Key_Alt_EDelete : constant Character := Character'Val (16#A3#);
Key_Alt_KPSlash : constant Character := Character'Val (16#A4#);
Key_Alt_Tab : constant Character := Character'Val (16#A5#);
Key_Alt_Enter : constant Character := Character'Val (16#A6#);
--------------------
-- CURSOR CONTROL --
--------------------
function Where_X return X_Pos;
function Where_Y return Y_Pos;
procedure Goto_XY (X : in X_Pos := X_Pos'First;
Y : in Y_Pos := Y_Pos'First);
-------------------
-- COLOR CONTROL --
-------------------
function Get_Foreground return Color_Type;
function Get_Background return Color_Type;
procedure Set_Foreground (Color : in Color_Type := Gray);
procedure Set_Background (Color : in Color_Type := Black);
--------------------
-- SCREEN CONTROL --
--------------------
procedure Clear_Screen (Color : in Color_Type := Black);
-------------------
-- SOUND CONTROL --
-------------------
procedure Bleep;
-------------------
-- INPUT CONTROL --
-------------------
function Get_Key return Character;
function Key_Available return Boolean;
end NT_Console;
-----------------------------------------------------------------------
--
-- File: nt_console.adb
-- Description: Win95/NT console support
-- Rev: 0.1
-- Date: 18-jan-1998
-- Author: Jerry van Dijk
-- Mail: jdijk@acm.org
--
-- Copyright (c) Jerry van Dijk, 1997, 1998
-- Billie Holidaystraat 28
-- 2324 LK LEIDEN
-- THE NETHERLANDS
-- tel int + 31 71 531 43 65
--
-- Permission granted to use for any purpose, provided this copyright
-- remains attached and unmodified.
--
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
--
-----------------------------------------------------------------------
pragma C_Pass_By_Copy (128);
with Interfaces; use Interfaces;
package body NT_Console is
pragma Linker_Options ("-luser32");
---------------------
-- WIN32 INTERFACE --
---------------------
Beep_Error : exception;
Fill_Char_Error : exception;
Cursor_Pos_Error : exception;
Buffer_Info_Error : exception;
Set_Attribute_Error : exception;
Invalid_Handle_Error : exception;
Fill_Attribute_Error : exception;
Cursor_Position_Error : exception;
subtype DWORD is Unsigned_32;
subtype HANDLE is Unsigned_32;
subtype WORD is Unsigned_16;
subtype SHORT is Short_Integer;
type LPDWORD is access all DWORD;
pragma Convention (C, LPDWORD);
type Nibble is mod 2 ** 4;
for Nibble'Size use 4;
type Attribute is
record
Foreground : Nibble;
Background : Nibble;
Reserved : Unsigned_8 := 0;
end record;
for Attribute use
record
Foreground at 0 range 0 .. 3;
Background at 0 range 4 .. 7;
Reserved at 1 range 0 .. 7;
end record;
for Attribute'Size use 16;
pragma Convention (C, Attribute);
type COORD is
record
X : SHORT;
Y : SHORT;
end record;
pragma Convention (C, COORD);
type SMALL_RECT is
record
Left : SHORT;
Top : SHORT;
Right : SHORT;
Bottom : SHORT;
end record;
pragma Convention (C, SMALL_RECT);
type CONSOLE_SCREEN_BUFFER_INFO is
record
Size : COORD;
Cursor_Pos : COORD;
Attrib : Attribute;
Window : SMALL_RECT;
Max_Size : COORD;
end record;
pragma Convention (C, CONSOLE_SCREEN_BUFFER_INFO);
type PCONSOLE_SCREEN_BUFFER_INFO is access all CONSOLE_SCREEN_BUFFER_INFO;
pragma Convention (C, PCONSOLE_SCREEN_BUFFER_INFO);
function GetCh return Integer;
pragma Import (C, GetCh, "_getch");
function KbHit return Integer;
pragma Import (C, KbHit, "_kbhit");
function MessageBeep (Kind : DWORD) return DWORD;
pragma Import (StdCall, MessageBeep, "MessageBeep");
function GetStdHandle (Value : DWORD) return HANDLE;
pragma Import (StdCall, GetStdHandle, "GetStdHandle");
function SetConsoleCursorPosition (Buffer : HANDLE; Pos : COORD) return DWORD;
pragma Import (StdCall, SetConsoleCursorPosition, "SetConsoleCursorPosition");
function SetConsoleTextAttribute (Buffer : HANDLE; Attr : Attribute) return DWORD;
pragma Import (StdCall, SetConsoleTextAttribute, "SetConsoleTextAttribute");
function GetConsoleScreenBufferInfo (Buffer : HANDLE; Info : PCONSOLE_SCREEN_BUFFER_INFO) return DWORD;
pragma Import (StdCall, GetConsoleScreenBufferInfo, "GetConsoleScreenBufferInfo");
function FillConsoleOutputCharacter (Console : HANDLE; Char : Character; Length : DWORD; Start : COORD; Written : LPDWORD) return DWORD;
pragma Import (Stdcall, FillConsoleOutputCharacter, "FillConsoleOutputCharacterA");
function FillConsoleOutputAttribute (Console : Handle; Attr : Attribute; Length : DWORD; Start : COORD; Written : LPDWORD) return DWORD;
pragma Import (Stdcall, FillConsoleOutputAttribute, "FillConsoleOutputAttribute");
WIN32_ERROR : constant DWORD := 0;
INVALID_HANDLE_VALUE : constant HANDLE := -1;
STD_OUTPUT_HANDLE : constant DWORD := -11;
Color_Value : constant array (Color_Type) of Nibble := (0, 1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 12, 13, 14, 15);
Color_Type_Value : constant array (Nibble) of Color_Type := (Black, Blue, Green, Cyan, Red, Magenta, Brown, Gray,
Black, Light_Blue, Light_Green, Light_Cyan, Light_Red,
Light_Magenta, Yellow, White);
-----------------------
-- PACKAGE VARIABLES --
-----------------------
Output_Buffer : HANDLE;
Num_Bytes : aliased DWORD;
Num_Bytes_Access : LPDWORD := Num_Bytes'Access;
Buffer_Info_Rec : aliased CONSOLE_SCREEN_BUFFER_INFO;
Buffer_Info : PCONSOLE_SCREEN_BUFFER_INFO := Buffer_Info_Rec'Access;
-------------------------
-- SUPPORTING SERVICES --
-------------------------
procedure Get_Buffer_Info is
begin
if GetConsoleScreenBufferInfo (Output_Buffer, Buffer_Info) = WIN32_ERROR then
raise Buffer_Info_Error;
end if;
end Get_Buffer_Info;
--------------------
-- CURSOR CONTROL --
--------------------
function Where_X return X_Pos is
begin
Get_Buffer_Info;
return X_Pos (Buffer_Info_Rec.Cursor_Pos.X);
end Where_X;
function Where_Y return Y_Pos is
begin
Get_Buffer_Info;
return Y_Pos (Buffer_Info_Rec.Cursor_Pos.Y);
end Where_Y;
procedure Goto_XY (X : in X_Pos := X_Pos'First;
Y : in Y_Pos := Y_Pos'First) is
New_Pos : COORD := (SHORT (X), SHORT (Y));
begin
Get_Buffer_Info;
if New_Pos.X > Buffer_Info_Rec.Size.X then
New_Pos.X := Buffer_Info_Rec.Size.X;
end if;
if New_Pos.Y > Buffer_Info_Rec.Size.Y then
New_Pos.Y := Buffer_Info_Rec.Size.Y;
end if;
if SetConsoleCursorPosition (Output_Buffer, New_Pos) = WIN32_ERROR then
raise Cursor_Pos_Error;
end if;
end Goto_XY;
-------------------
-- COLOR CONTROL --
-------------------
function Get_Foreground return Color_Type is
begin
Get_Buffer_Info;
return Color_Type_Value (Buffer_Info_Rec.Attrib.Foreground);
end Get_Foreground;
function Get_Background return Color_Type is
begin
Get_Buffer_Info;
return Color_Type_Value (Buffer_Info_Rec.Attrib.Background);
end Get_Background;
procedure Set_Foreground (Color : in Color_Type := Gray) is
Attr : Attribute;
begin
Get_Buffer_Info;
Attr.Foreground := Color_Value (Color);
Attr.Background := Buffer_Info_Rec.Attrib.Background;
if SetConsoleTextAttribute (Output_Buffer, Attr) = WIN32_ERROR then
raise Set_Attribute_Error;
end if;
end Set_Foreground;
procedure Set_Background (Color : in Color_Type := Black) is
Attr : Attribute;
begin
Get_Buffer_Info;
Attr.Foreground := Buffer_Info_Rec.Attrib.Foreground;
Attr.Background := Color_Value (Color);
if SetConsoleTextAttribute (Output_Buffer, Attr) = WIN32_ERROR then
raise Set_Attribute_Error;
end if;
end Set_Background;
--------------------
-- SCREEN CONTROL --
--------------------
procedure Clear_Screen (Color : in Color_Type := Black) is
Attr : Attribute;
Home : COORD := (0, 0);
Length : DWORD := DWORD ((X_Pos'Last + 1) * (Y_Pos'Last + 1));
begin
Get_Buffer_Info;
Attr.Background := Color_Value (Color);
Attr.Foreground := Buffer_Info_Rec.Attrib.Foreground;
if SetConsoleTextAttribute (Output_Buffer, Attr) = WIN32_ERROR then
raise Set_Attribute_Error;
end if;
if FillConsoleOutputAttribute (Output_Buffer, Attr, Length, Home, Num_Bytes_Access) = WIN32_ERROR then
raise Fill_Attribute_Error;
end if;
if FillConsoleOutputCharacter (Output_Buffer, ' ', Length, Home, Num_Bytes_Access) = WIN32_ERROR then
raise Fill_Char_Error;
end if;
if SetConsoleCursorPosition (Output_Buffer, Home) = WIN32_ERROR then
raise Cursor_Position_Error;
end if;
end Clear_Screen;
-------------------
-- SOUND CONTROL --
-------------------
procedure Bleep is
begin
if MessageBeep (16#FFFFFFFF#) = WIN32_ERROR then
raise Beep_Error;
end if;
end Bleep;
-------------------
-- INPUT CONTROL --
-------------------
function Get_Key return Character is
Temp : Integer;
begin
Temp := GetCh;
if Temp = 16#00E0# then
Temp := 0;
end if;
return Character'Val (Temp);
end Get_Key;
function Key_Available return Boolean is
begin
if KbHit = 0 then
return False;
else
return True;
end if;
end Key_Available;
begin
--------------------------
-- WIN32 INITIALIZATION --
--------------------------
Output_Buffer := GetStdHandle (STD_OUTPUT_HANDLE);
if Output_Buffer = INVALID_HANDLE_VALUE then
raise Invalid_Handle_Error;
end if;
end NT_Console;
--
=======================================================================
Life is short. | Craig Spannring
Bike hard, ski fast. | cts@internetcds.com
--------------------------------+------------------------------------
next prev parent reply other threads:[~2000-08-26 0:00 UTC|newest]
Thread overview: 10+ messages / expand[flat|nested] mbox.gz Atom feed top
2000-08-25 0:00 change screen colour?? Damon Carter
2000-08-26 2:53 ` DuckE
2000-08-26 0:00 ` Damon Carter
2000-08-26 0:00 ` tmoran
2000-08-26 0:00 ` Marin D. Condic
2000-08-27 7:26 ` more specific Damon Carter
2000-08-26 0:00 ` Al Christians
2000-08-26 0:00 ` (null) [this message]
2000-08-26 0:00 ` more specific, was:change screen colour?? tmoran
2000-08-28 0:00 ` Jerry van Dijk
replies disabled
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox