CICA 1993 August/CICA.cdr/unzipped/programr/tp/sycolor/syscolor.pas

Pascal/Delphi Source File | 1991-02-28 | 15.9 KB | 574 lines

{ 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
  ------------------------------------------------------------- }