syscolor.pas

汇编源代码大全2

{ 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, ClrArray)
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,