syscolor.pas

汇编源代码大全2

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