Category : Pascal Source Code
Archive   : SYSCOLOR.ZIP
Filename : SYSCOLOR.PAS

 
Output of file : SYSCOLOR.PAS contained in archive : SYSCOLOR.ZIP
{ syscolor.pas -- Set System Colors (c) 1991 by Tom Swan.}

{$R syscolor.res }

program SysColor;

uses WinTypes, WinProcs, WObjects, Strings;

const

app_Name = 'SysColor'; { Application name }
ini_FName = 'SYSCOLOR.INI'; { .INI file name }

id_Menu = 100; { Menu resource ID }
id_Icon = 200; { Icon resource ID }
cm_About = 101; { Menu:About command resource ID }
cm_Quit = 102; { Menu:Exit command resource ID }

id_SBarRed = 100; { Window control IDs }
id_SBarGrn = 101;
id_SBarBlu = 102;
id_STxtRed = 103;
id_STxtGrn = 104;
id_STxtBlu = 105;
id_SetBtn = 106;
id_ResetBtn = 107;
id_SaveBtn = 108;
id_QuitBtn = 109;

RedMask = $000000FF; { Color value extraction masks }
GrnMask = $0000FF00;
BluMask = $00FF0000;

nonStop: Boolean = false; { Use switches: -s = false; -n = true }

SysColorName: Array[0 .. color_EndColors] of PChar = (
'Scroll Bar',
'Background',
'Active Caption',
'Inactive Caption',
'Menu',
'Window',
'Window Frame',
'Menu Text',
'Window Text',
'Caption Text',
'Active Border',
'Inactive Border',
'App Work Space',
'Highlight',
'Highlight Text',
'Button Face',
'Button Shadow',
'Gray Text',
'Button Text'
);

type

SCApplication = object(TApplication)
constructor Init(AName: PChar);
procedure InitMainWindow; virtual;
end;

PSCWindow = ^SCWindow;
SCWindow = object(TWindow)

{- SCWindow data fields }
Dc: Hdc;
ButtonDown, Changed: Boolean;
LineX1, LineY1, LineX2, LineY2: Integer;
ArrowCursor, CrossHairCursor: HCursor;
RedColor, GrnColor, BluColor: Byte;
SBarRed, SBarGrn, SBarBlu: PScrollBar;
STxtRed, STxtGrn, STxtBlu: PStatic;
SampleRect: TRect;
SampleColor: TColorRef;
DraggingOrigin: Integer;

{- SCWindow inherited methods }
constructor Init(AParent: PWindowsObject; ATitle: PChar);
function CanClose: Boolean; virtual;
procedure GetWindowClass(var AWndClass: TWndClass); virtual;
procedure SetupWindow; virtual;
procedure WMLButtonDown(var Msg: TMessage);
virtual wm_First + wm_LButtonDown;
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;

{- SCWindow new methods }
function InsideColorRect(X, Y: Integer; var Index: Integer): Boolean;
procedure ResetSystemColors;
procedure SynchronizeScrollBars;
procedure DrawRubberband;
procedure CMAbout(var Msg: TMessage); virtual cm_First + cm_About;
procedure CMQuit(var Msg: TMessage); virtual cm_First + cm_Quit;
procedure WMLButtonUp(var Msg: TMessage); virtual wm_First + wm_LButtonUp;
procedure WMMouseMove(var Msg: TMessage); virtual wm_First + wm_MouseMove;
procedure SBarRedEvent(var Msg: TMessage); virtual id_First + id_SBarRed;
procedure SBarGrnEvent(var Msg: TMessage); virtual id_First + id_SBarGrn;
procedure SBarBluEvent(var Msg: TMessage); virtual id_First + id_SBarBlu;
procedure SetBtnEvent(var Msg: TMessage); virtual id_First + id_SetBtn;
procedure ResetBtnEvent(var Msg: TMessage); virtual id_First + id_ResetBtn;
procedure SaveBtnEvent(var Msg: TMessage); virtual id_First + id_SaveBtn;
procedure QuitBtnEvent(var Msg: TMessage); virtual id_First + id_QuitBtn;
end;

SysColorRec = record
OriginalColor: LongInt; { Color on starting program }
CurrentColor: LongInt; { New color selected by user }
SCRect: TRect; { Location of system-color rectangle }
end;

var

SysColorArray: Array[0 .. color_EndColors] of SysColorRec;


{----- Common routines -----}

{- Convert integer N to C char array. If Max > 0, pad with leading 0s. }
procedure Int2Str(N, Max: Integer; C: PChar);
var
S: String[6];
begin
Str(N, S);
while Length(S) < Max do S := '0' + S;
StrPCopy(C, S)
end;

{- Prepare global SysColorArray with current color values }
procedure InitSysColorArray;
var
I: Integer;
begin
for I := 0 to color_EndColors do with SysColorArray[I] do
begin
OriginalColor := GetSysColor(I);
CurrentColor := OriginalColor;
with SCRect do
begin
Left := 500;
Top := 20 + (I * 20);
Right := Left + 100;
Bottom := Top + 15
end
end
end;

{- Change system colors to values in SysColorArray }
procedure ChangeSystemColors;
var
I: Integer;
InxArray: Array[0 .. color_EndColors] of Integer;
ClrArray: Array[0 .. color_EndColors] of TColorRef;
begin
for I := 0 to color_EndColors do
begin
InxArray[I] := I;
ClrArray[I] := SysColorArray[I].CurrentColor
end;
SetSysColors(color_EndColors + 1, InxArray[0], ClrArray[0])
end;

{- Save colors to SYSCOLOR.INI in Windows directory }
function SaveSettings: Boolean;
var
I: Integer;
S: String[12];
NewValue: array[0 .. 12] of Char;
begin
SaveSettings := true; { Think positively! }
for I := 0 to color_EndColors do with SysColorArray[I] do
begin
Str(CurrentColor, S);
StrPCopy(NewValue, S);
if not WritePrivateProfileString(app_Name, SysColorName[I],
NewValue, ini_FName) then
begin
SaveSettings := false;
Exit
end
end
end;

{- Load colors from SYSCOLOR.INI if present }
procedure LoadSettings;
var
I, Err: Integer;
S: String[12];
DefaultValue, NewValue: array[0 .. 12] of Char;
begin
for I := 0 to color_EndColors do with SysColorArray[I] do
begin
Str(CurrentColor, S);
StrPCopy(DefaultValue, S);
GetPrivateProfileString(app_Name, SysColorName[I],
DefaultValue, NewValue, sizeof(NewValue), ini_FName);
S := StrPas(NewValue);
Val(S, CurrentColor, Err);
if Err <> 0 then CurrentColor := OriginalColor
end;
GetPrivateProfileString(app_Name, 'nonstop',
'false', NewValue, sizeof(NewValue), ini_FName);
if StrComp('false', NewValue) <> 0
then nonStop := true
end;

{- Get command-line switches }
procedure GetSwitches;
var
I: Integer;
S: String[128];
C: Char;
begin
for I := 1 to ParamCount do
begin
S := ParamStr(I);
C := upcase(S[1]);
if (Length(S) > 1) and ((C = '-') or (C = '/')) then
case upcase(S[2]) of
'N' : nonStop := true;
'S' : nonStop := false
end
end
end;


{----- SCApplication methods -----}

{- Construct SCApplication object }
constructor SCApplication.Init(AName: PChar);
begin
TApplication.Init(AName);
InitSysColorArray; { Initialize colors }
LoadSettings; { Load .INI settings if present }
GetSwitches; { Get command-line switches }
if nonStop then
begin
ChangeSystemColors; { Change colors to .INI settings }
PostQuitMessage(0); { Exit without stopping }
end
end;

{- Initialize application's window }
procedure SCApplication.InitMainWindow;
begin
MainWindow := New(PSCWindow, Init(nil, 'Set System Colors'))
end;


{----- SCWindow methods -----}

{- Construct SCWindow object and instantiate child windows }
constructor SCWindow.Init(AParent: PWindowsObject; ATitle: PChar);
var
AStat: PStatic;
ABtn: PButton;
begin
TWindow.Init(AParent, ATitle);
Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
with Attr do
begin
X := 10; Y := 10; H := 460; W := 615
end;
ButtonDown := false;
Changed := false;
ArrowCursor := LoadCursor(0, idc_Arrow);
CrossHairCursor := LoadCursor(0, idc_Cross);
RedColor := 0;
GrnColor := 0;
BluColor := 0;
SampleColor := 0;
with SampleRect do
begin
Left := 200; Top := 150; Right := 300; Bottom := 230;
end;
SBarRed := New(PScrollBar, Init(@Self, id_SBarRed, 50, 20, 250, 0, True));
SBarGrn := New(PScrollBar, Init(@Self, id_SBarGrn, 50, 60, 250, 0, True));
SBarBlu := New(PScrollBar, Init(@Self, id_SBarBlu, 50, 100, 250, 0, True));
AStat := New(PStatic, Init(@Self, 0, 'Red', 5, 20, 40, 20, 3));
AStat := New(PStatic, Init(@Self, 0, 'Green', 5, 60, 40, 20, 5));
AStat := New(PStatic, Init(@Self, 0, 'Blue', 5, 100, 40, 20, 4));
AStat := New(PStatic, Init(@Self, 0, 'Color', 235, 240, 40, 20, 5));
STxtRed := New(PStatic, Init(@Self, id_STxtRed, '000', 310, 20, 40, 20, 3));
STxtGrn := New(PStatic, Init(@Self, id_STxtGrn, '000', 310, 60, 40, 20, 3));
STxtBlu := New(PStatic, Init(@Self, id_STxtBlu, '000', 310, 100, 40, 20, 3));
ABtn := New(PButton, Init(@Self, id_SetBtn,
'Set', 50, 150, 80, 40, false));
ABtn := New(PButton, Init(@Self, id_ResetBtn,
'Reset', 50, 210, 80, 40, false));
ABtn := New(PButton, Init(@Self, id_SaveBtn,
'Save', 50, 270, 80, 40, false));
ABtn := New(PButton, Init(@Self, id_QuitBtn,
'Quit', 50, 330, 80, 40, true))
end;

{- Return true if window may close }
function SCWindow.CanClose: Boolean;
var
Answer: Integer;
begin
CanClose := true;
if Changed then
begin
Answer := MessageBox(HWindow, 'Save colors before quitting?',
'Please answer', mb_YesNoCancel or mb_IconQuestion);
if Answer = idYes then
CanClose := SaveSettings
else if Answer = idCancel then
CanClose := false
end
end;

{- Reset system colors to values saved at start of program }
procedure SCWindow.ResetSystemColors;
var
I: Integer;
begin
for I := 0 to color_EndColors do with SysColorArray[I] do
CurrentColor := OriginalColor;
Changed := false
end;

{- Modify window class to use custom icon }
procedure SCWindow.GetWindowClass(var AWndClass: TWndClass);
begin
TWindow.GetWindowClass(AWndClass);
AWndClass.hIcon := LoadIcon(HInstance, PChar(id_Icon))
end;

{- Perform setup duties for a newly created SCWindow object. }
procedure SCWindow.SetupWindow;
begin
TWindow.SetupWindow;
SBarRed^.SetRange(0, 255);
SBarGrn^.SetRange(0, 255);
SBarBlu^.SetRange(0, 255)
end;

{- Adjust scroll bars to match SampleColor }
procedure SCWindow.SynchronizeScrollBars;
var
DummyMsg: TMessage;
begin
SBarRed^.SetPosition(SampleColor and RedMask);
SBarGrn^.SetPosition((SampleColor and GrnMask) shr 8);
SBarBlu^.SetPosition((SampleColor and BluMask) shr 16);
SBarRedEvent(DummyMsg);
SBarGrnEvent(DummyMsg);
SBarBluEvent(DummyMsg)
end;

{- Display "About program" dialog box }
procedure SCWindow.CMAbout(var Msg: TMessage);
var
Dialog: TDialog;
begin
Dialog.Init(@Self, 'About');
Dialog.Execute;
Dialog.Done
end;

{- Execute Menu:Exit command }
procedure SCWindow.CMQuit(var Msg: TMessage);
begin
PostQuitMessage(0)
end;

{- Draw rubberband connecting line while dragging colors }
procedure SCWindow.DrawRubberband;
begin
MoveTo(Dc, LineX1, LineY1);
LineTo(Dc, LineX2, LineY2)
end;

{- Return true if point X, Y is inside a color rectangle }
function SCWindow.InsideColorRect(X, Y: Integer; var Index: Integer): Boolean;
var
CursorLocation: TPoint;
I: Integer;
begin
CursorLocation.X := X;
CursorLocation.Y := Y;
InsideColorRect := true;
if PtInRect(SampleRect, CursorLocation) then
begin
Index := -1; { Inside sample color box }
Exit
end else
for I := 0 to color_EndColors do
if PtInRect(SysColorArray[I].SCRect, CursorLocation) then
begin
Index := I; { Inside a system color rectangle }
Exit
end;
InsideColorRect := false
end;

{- Handle left-button down event }
procedure SCWindow.WMLButtonDown(var Msg: TMessage);
begin
if not ButtonDown then with Msg do
if InsideColorRect(LParamLo, LParamHi, DraggingOrigin) then
begin
Dc := GetDC(HWindow);
LineX1 := LParamLo;
LineY1 := LParamHi;
LineX2 := LineX1;
LineY2 := LineY1;
SetROP2(Dc, r2_Not);
DrawRubberband;
ButtonDown := true;
SetCursor(CrossHairCursor);
SetCapture(HWindow);
if DraggingOrigin >= 0 then {- Clicked in a system color rectangle }
begin
SampleColor := SysColorArray[DraggingOrigin].CurrentColor;
SynchronizeScrollBars
end
end
end;

{- Handle left-button up event }
procedure SCWindow.WMLButtonUp(var Msg: TMessage);
var
Index: Integer;
NewColor: TColorRef;
begin
if ButtonDown then with Msg do
begin
if InsideColorRect(LParamLo, LParamHi, Index) then
if (Index <> DraggingOrigin) and (Index >= 0) then
begin
Changed := true;
if DraggingOrigin >= 0
then NewColor := SysColorArray[DraggingOrigin].CurrentColor
else NewColor := SampleColor;
SysColorArray[Index].CurrentColor := NewColor;
InvalidateRect(HWindow, nil, False)
end;
DrawRubberband; { Erase last line }
SetROP2(Dc, r2_Black);
ButtonDown := false;
SetCursor(ArrowCursor);
ReleaseDC(HWindow, Dc);
ReleaseCapture
end
end;

{- Handle mouse-move event }
procedure SCWindow.WMMouseMove(var Msg: TMessage);
begin
if ButtonDown then
begin
DrawRubberband; { Erase old line }
with Msg do
begin
LineX2 := LParamLo;
LineY2 := LParamHi;
DrawRubberband { Draw new line }
end
end
end;

{- Handle change to red scroll bar position }
procedure SCWindow.SBarRedEvent(var Msg: TMessage);
var
C: Array[0 .. 3] of Char;
begin
RedColor := SBarRed^.GetPosition;
Int2Str(RedColor, 3, C);
STxtRed^.SetText(C);
SampleColor := RGB(RedColor, GrnColor, BluColor);
InvalidateRect(HWindow, @SampleRect, False)
end;

{- Handle change to green scroll bar position }
procedure SCWindow.SBarGrnEvent(var Msg: TMessage);
var
C: Array[0 .. 3] of Char;
begin
GrnColor := SBarGrn^.GetPosition;
Int2Str(GrnColor, 3, C);
STxtGrn^.SetText(C);
SampleColor := RGB(RedColor, GrnColor, BluColor);
InvalidateRect(HWindow, @SampleRect, False)
end;

{- Handle change to blue scroll bar position }
procedure SCWindow.SBarBluEvent(var Msg: TMessage);
var
C: Array[0 .. 3] of Char;
begin
BluColor := SBarBlu^.GetPosition;
Int2Str(BluColor, 3, C);
STxtBlu^.SetText(C);
SampleColor := RGB(RedColor, GrnColor, BluColor);
InvalidateRect(HWindow, @SampleRect, False)
end;

procedure SCWindow.SetBtnEvent(var Msg: TMessage);
begin
ChangeSystemColors
end;

procedure SCWindow.ResetBtnEvent(var Msg: TMessage);
begin
ResetSystemColors;
ChangeSystemColors
end;

procedure SCWindow.SaveBtnEvent(var Msg: TMessage);
begin
if SaveSettings then Changed := false
end;

procedure SCWindow.QuitBtnEvent(var Msg: TMessage);
begin
PostQuitMessage(0)
end;

procedure SCWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
OldBrush, TheBrush: HBrush;
I: Integer;

procedure ShowSysColor(I: Integer);
var
SysColorBrush : HBrush;
OldBrush: HBrush;
SCName : PChar;
begin
with SysColorArray[I], SCRect do
begin
SysColorBrush := CreateSolidBrush(CurrentColor);
OldBrush := SelectObject(PaintDC, SysColorBrush);
Rectangle(PaintDC, Left, Top, Right, Bottom);
SelectObject(PaintDC, OldBrush);
DeleteObject(SysColorBrush);
SCName := SysColorName[I];
TextOut(PaintDC, Left - 125, Top, SCName, StrLen(SCName))
end
end;

begin
TheBrush := CreateSolidBrush(SampleColor);
OldBrush := SelectObject(PaintDC, TheBrush);
with SampleRect do Rectangle(PaintDC, Left, Top, Right, Bottom);
SelectObject(PaintDC, OldBrush);
DeleteObject(TheBrush);
for I := 0 to color_EndColors do
ShowSysColor(I)
end;

var

SCApp: SCApplication;

begin
SCApp.Init(app_Name);
SCApp.Run;
SCApp.Done
end.


{ --------------------------------------------------------------
Copyright (c) 1991 by Tom Swan. All rights reserved.
Revision 1.00 Date: 2/1/1991
Revision 1.01 Date: 2/27/1991
1. Changed all cm_Exit constants to cm_Quit
2. Changed all CMExit procedure names to CMQuit
3. Added length argument to all TStatic object inits
------------------------------------------------------------- }


  3 Responses to “Category : Pascal Source Code
Archive   : SYSCOLOR.ZIP
Filename : SYSCOLOR.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/