cbtnform.pas

动态提示控件

  if (Y = 0) then
  begin
    { other square }
    X := ClientWidth - 18;
    Y := btnOther.Top + ((btnOther.Height - 16) div 2);
  end else if ValidColorIndex(X, Y) then
  begin
    X := (X-1) * 18 + 1;
    Y := (Y-1) * 18 + 1;
  end else
    exit;

  Result := Rect(X-1, Y-1, X+17, Y+17);
end;

procedure TDFSColorButtonPalette.DrawSquare(X, Y: integer; AColor: TColor;
   IsFocused: boolean);
var
  R: TRect;
begin
  R := GetSquareCoords(X, Y);
  if IsRectEmpty(R) then
    exit;

  if (Y = 0) then
    AColor := FOtherColor;

  with Canvas do
  begin
    if IsFocused then
    begin
      Brush.Color := {$IFDEF DFS_WIN32} cl3DDkShadow; {$ELSE} clBlack; {$ENDIF}
      FrameRect(R);
      InflateRect(R, -1, -1);
      Brush.Color := clBtnHighlight;
      FrameRect(R);
      InflateRect(R, -1, -1);
      Brush.Color := {$IFDEF DFS_WIN32} cl3DDkShadow; {$ELSE} clBlack; {$ENDIF}
      FrameRect(R);
      InflateRect(R, -1, -1);
    end else begin
      { Get rid of any focus framing rect left over from previous paint }
      Brush.Color := Self.Color;
      FrameRect(R);
      InflateRect(R, -1, -1);
      { Draw a 3D frame }
      Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1);
      { Frame3D reduces the rectangle size by 1 }
      Frame3D(Canvas, R, {$IFDEF DFS_WIN32} cl3DDkShadow {$ELSE} clBlack {$ENDIF},
          {$IFDEF DFS_WIN32} cl3DLight {$ELSE} clSilver {$ENDIF}, 1);
    end;
    { Paint the color }
    Brush.Color := AColor;
    FillRect(R);
  end;
end;

function ColorEnumProc(Pen : PLogPen; Colors : PColorArrayCallback): integer;
   {$IFDEF DFS_WIN32} stdcall; {$ELSE} export; {$ENDIF}
begin
  if Pen^.lopnStyle = PS_SOLID then
  begin
    if Colors^[0] < 20 then
    begin
      inc(Colors^[0]);
      Colors^[Colors^[0]] := Pen^.lopnColor;
      Result := 1;
    end else
      Result := 0;
  end else
    Result := 1;
end;

procedure TDFSColorButtonPalette.FormCreate(Sender: TObject);
var
  X, Y: integer;
  Colors: TColorArrayCallback;
  DC: HDC;
  {$IFNDEF DFS_WIN32}
  CallbackProc: TFarProc;
  {$ENDIF}
begin
  FPreventClose := FALSE;
  
  FOldAppDeactivate := Application.OnDeactivate;
  Application.OnDeactivate := AppDeactivate;
  FOldAppShowHint := Application.OnShowHint;
  Application.OnShowHint := PaletteShowHint;

  FLastFrame := Point(-1,-1);

  DC := GetDC(GetDesktopWindow);
  try
    if GetDeviceCaps(DC, NUMCOLORS) = 16 then
    begin
      { 16 color mode, enum colors to fill array }
      FillChar(Colors, SizeOf(Colors), #0);
      {$IFDEF DFS_WIN32}
      EnumObjects(DC, OBJ_PEN, @ColorEnumProc, LPARAM(@Colors));
      {$ELSE}
      CallbackProc := MakeProcInstance(@ColorEnumProc, hInstance);
      try
        EnumObjects(DC, OBJ_PEN, CallbackProc, @Colors);
      finally
        FreeProcInstance(CallbackProc);
      end;
      {$ENDIF}

      for X := 1 to 4 do
      begin
        for Y := 1 to 5 do
        begin
          FPaletteColors[X,Y] := Colors[(X-1)*5+Y];
        end;
      end;
    end else begin
      { Lots 'o colors, pick the ones we want. }
      FPaletteColors[1,1] := RGB(255,255,255);
      FPaletteColors[1,2] := RGB(255,0,0);
      FPaletteColors[1,3] := RGB(0,255,0);
      FPaletteColors[1,4] := RGB(0,0,255);
      FPaletteColors[1,5] := RGB(191,215,191);
      FPaletteColors[2,1] := RGB(0,0,0);
      FPaletteColors[2,2] := RGB(127,0,0);
      FPaletteColors[2,3] := RGB(0,127,0);
      FPaletteColors[2,4] := RGB(0,0,127);
      FPaletteColors[2,5] := RGB(159,191,239);
      FPaletteColors[3,1] := RGB(191,191,191);
      FPaletteColors[3,2] := RGB(255,255,0);
      FPaletteColors[3,3] := RGB(0,255,255);
      FPaletteColors[3,4] := RGB(255,0,255);
      FPaletteColors[3,5] := RGB(255,247,239);
      FPaletteColors[4,1] := RGB(127,127,127);
      FPaletteColors[4,2] := RGB(127,127,0);
      FPaletteColors[4,3] := RGB(0,127,127);
      FPaletteColors[4,4] := RGB(127,0,127);
      FPaletteColors[4,5] := RGB(159,159,159);
    end;
  finally
    ReleaseDC(GetDesktopWindow, DC);
  end;

  FOtherColor := clBtnFace;
  FStartColor := clBlack;

  { Oh, how I do hate large fonts. }
  ClientWidth := 72;
  btnOther.Top := 98;
  btnOther.Width := ClientWidth - 22;
  ClientHeight := btnOther.Top + btnOther.Height + 2;
end;

procedure TDFSColorButtonPalette.SetStartColor(Value: TColor);
var
  x, y: integer;
begin
  FStartColor := Value;
  { See if we have that color }
  for x := 1 to 4 do
  begin
    for y := 1 to 5 do
    begin
      if ColorToRGB(FPaletteColors[x,y]) = ColorToRGB(FStartColor) then
      begin
        FLastFrame := Point(x,y);
        DrawSquare(x, y, FStartColor, TRUE);
        exit;
      end;
    end;
  end;
  { didn't find it }
  FOtherColor := FStartColor;
end;

procedure TDFSColorButtonPalette.SetShowColorHints(Val: boolean);
begin
  FShowColorHints := Val;
  ShowHint := Val;
end;

procedure TDFSColorButtonPalette.AppDeactivate(Sender: TObject);
begin
  if FPreventClose then
    exit;

  if assigned(FOldAppDeactivate) then
    FOldAppDeactivate(Sender);

  Close;
end;

function TDFSColorButtonPalette.BuildHintText(AColor: TColor;
   X, Y: integer): string;
type
  {$IFNDEF DFS_WIN32}
  DWORD = longint;
  {$ENDIF}
  TRGBMap = packed record
    case boolean of
      TRUE:  ( RGBVal: DWORD );
      FALSE: ( Red,
               Green,
               Blue,
               Unused: byte );
  end;
var
  RGBColor: TRGBMap;
begin
  RGBColor.RGBVal := ColorToRGB(AColor);
  { for hex, you could use:
  HintStr := Format('RGB = %.2x %.2x %.2x', [AColor.Red, AColor.Green,}
  Result := Format('RGB = %.3d %.3d %.3d', [RGBColor.Red, RGBColor.Green,
     RGBColor.Blue]);

  GetColorHintText(AColor, X, Y, Result);
end;

procedure TDFSColorButtonPalette.PaletteShowHint(var HintStr: string;
   var CanShow: Boolean; var HintInfo: THintInfo);
var
  CS: TPoint;
  AColor: TColor;
begin
  if HintInfo.HintControl = Self then
  begin
    CS := GetCurrentSquare;
    if ValidColorIndex(CS.X, CS.Y) then
    begin
      { Hint is valid as long as cursor stays inside this color square }
      HintInfo.CursorRect := GetSquareCoords(CS.X, CS.Y);
      if CS.Y = 0 then
        AColor := FOtherColor
      else
        AColor := FPaletteColors[CS.X, CS.Y];

      HintStr := BuildHintText(AColor, CS.X, CS.Y);

      CanShow := HintStr <> '';

      {$IFNDEF DFS_DELPHI_3_UP}
      if CanShow then
      begin
        CS.X := HintInfo.CursorRect.Left;
        CS.Y := HintInfo.CursorRect.Bottom + 8;
        HintInfo.HintPos := ClientToScreen(CS);
      end;
      {$ENDIF}
    end else
      CanShow := FALSE;
  end;
  if assigned(FOldAppShowHint) then
    FOldAppShowHint(HintStr, CanShow, HintInfo);
end;

procedure TDFSColorButtonPalette.btnOtherClick(Sender: TObject);
var
  AColor: TColor;
  c: char;
  p: integer;
  y: integer;
  x: integer;
  z: integer;
  Dlg: TColorDialog;
  ColorPicked: boolean;
begin
  Dlg := TColorDialog.Create(Self);
  try
    FPreventClose := TRUE;
    Dlg.Color := FOtherColor;
    Dlg.Options := [cdFullOpen];
    { set custom colors here }
    for x := 1 to 8 do
    begin
      for y := 1 to 2 do
      begin
        c := Chr((y-1)*8+x + 64);
        Dlg.CustomColors.Add('Color' + c + '=' + IntToHex(CustomColors[x,y], 8));
      end;
    end;
    ColorPicked := Dlg.Execute;
    if ColorPicked then
    begin
      FOtherColor := Dlg.Color;
      { get custom colors here }
      for z := 0 to 15 do
      begin
        p := Pos('=', Dlg.CustomColors[z]);
        AColor := StrToIntDef('$'+Copy(Dlg.CustomColors[z], p+1, 9), clWhite);
        p := Ord(Dlg.CustomColors[z][p-1]) - 64;
        x := (p-1) mod 8 + 1;
        y := (p-1) div 8 + 1;
        CustomColors[x,y] := AColor;
      end;
    end;
  finally
    FPreventClose := FALSE;
    Dlg.Free;
  end;

  if ColorPicked then
  begin
    if assigned(FSetParentColor) then
      FSetParentColor(Self, TRUE, FOtherColor);
    Close;
  end;
end;

procedure TDFSColorButtonPalette.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  CanClose := not FPreventClose;
end;

function TDFSColorButtonPalette.ValidColorIndex(X, Y: integer): boolean;
begin
  Result := ((X > 0) and (X <= 4) and (Y > 0) and (Y <= 5)) or (Y = 0);
end;

procedure TDFSColorButtonPalette.FrameCurrentSquare(NewFrame: TPoint);

  function ComparePoints(const Pt1, Pt2: TPoint): boolean;
  begin
    Result := ((Pt1.X = Pt2.X) and (Pt1.Y =Pt2.Y));
  end;

var
  AColor: TColor;
begin
  if not ComparePoints(NewFrame, FLastFrame) and
     ValidColorIndex(NewFrame.X, NewFrame.Y) then
  begin
    { Unframe the last one }
    if ValidColorIndex(FLastFrame.X, FLastFrame.Y) then
    begin
      if FLastFrame.Y = 0 then
        AColor := FOtherColor
      else
        AColor := FPaletteColors[FLastFrame.X, FLastFrame.Y];
      with FLastFrame do
        DrawSquare(X, Y, AColor, FALSE);
    end;

		if NewFrame.Y = 0 then
      AColor := FOtherColor
    else
      AColor := FPaletteColors[NewFrame.X, NewFrame.Y];
    with NewFrame do
      DrawSquare(X, Y, AColor, TRUE);
    FLastFrame := NewFrame;
  end;
end;


procedure TDFSColorButtonPalette.FormMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  FrameCurrentSquare(GetCurrentSquare);
end;

procedure TDFSColorButtonPalette.FormClick(Sender: TObject);
var
  SelectedColorSquare: TPoint;
  AColor: TColor;
begin
  if assigned(FSetParentColor) then
  begin
    SelectedColorSquare := GetCurrentSquare;
    if ValidColorIndex(SelectedColorSquare.X, SelectedColorSquare.Y) then
    begin
      if (SelectedColorSquare.Y = 0) then
        AColor := FOtherColor
      else
        AColor := FPaletteColors[SelectedColorSquare.x, SelectedColorSquare.Y];
      FSetParentColor(Self, (SelectedColorSquare.Y = 0), AColor);
    end;
  end;
  Close;
end;

function TDFSColorButtonPalette.GetCurrentSquare: TPoint;

  function IsOtherColorSquare(Pt: TPoint): boolean;
  begin
    Result := (Pt.X >= ClientWidth-19) and (Pt.X <= ClientWidth-1) and
       (Pt.Y >= 96) and (Pt.Y <= 113);
  end;

var
  CurPos: TPoint;
begin
  GetCursorPos(CurPos);
  CurPos := ScreenToClient(CurPos);
  Result := Point((CurPos.X div 18) + 1, (CurPos.Y div 18) + 1);
  if IsOtherColorSquare(CurPos) then
    Result := Point(0,0)
  else if not ValidColorIndex(Result.X, Result.Y) then
    Result := Point(-1,-1);
end;

procedure TDFSColorButtonPalette.FormKeyPress(Sender: TObject;
  var Key: Char);
var
  SelectedColorSquare: TPoint;
  AColor: TColor;
begin
  case Key of
    #27:
      begin
        FKeyboardClose := TRUE;
        Close;
      end;
    #13:
      begin
        if assigned(FSetParentColor) then
        begin
          SelectedColorSquare := FLastFrame;
          if ValidColorIndex(SelectedColorSquare.X, SelectedColorSquare.Y) then
          begin
            if (SelectedColorSquare.Y = 0) then
              AColor := FOtherColor
            else
              AColor := FPaletteColors[SelectedColorSquare.x,
                 SelectedColorSquare.Y];
            FSetParentColor(Self, (SelectedColorSquare.Y = 0), AColor);
          end;
        end;
        FKeyboardClose := TRUE;
        Close;
      end;
  end;
end;

procedure TDFSColorButtonPalette.FormDestroy(Sender: TObject);
begin
  Application.OnDeactivate := FOldAppDeactivate;
  Application.OnShowHint := FOldAppShowHint;
end;

procedure TDFSColorButtonPalette.SetPaletteColors(Value: TPaletteColors);
begin
  FPaletteColors.Assign(Value);
end;

procedure TDFSColorButtonPalette.SetCustomColors(Value: TCustomColors);
begin
  FCustomColors.Assign(Value);
end;


procedure TDFSColorButtonPalette.FormKeyDown(Sender: TObject;
  var Key: Word; Shift: TShiftState);
var
  FrameIt: boolean;
  NewFrame: TPoint;
begin
  FrameIt := TRUE;
  NewFrame := FLastFrame;
  if ValidColorIndex(NewFrame.X, NewFrame.Y) then
  begin
    case Key of
      VK_LEFT:
        begin
          if NewFrame.Y = 0 then
            exit;
          dec(NewFrame.X);
          if NewFrame.X < 1 then
            NewFrame.X := 4
          else if NewFrame.X > 4 then
            NewFrame.X := 1;
        end;
      VK_UP:
        begin
          dec(NewFrame.Y);
          if NewFrame.Y < 0 then
            NewFrame.Y := 5
          else if NewFrame.Y > 5 then
            NewFrame.Y := 0;
        end;
      VK_RIGHT:
        begin
          if NewFrame.Y = 0 then
            exit;
          inc(NewFrame.X);
          if NewFrame.X < 1 then
            NewFrame.X := 4
          else if NewFrame.X > 4 then
            NewFrame.X := 1;
        end;
      VK_DOWN:
        begin
          inc(NewFrame.Y);
          if NewFrame.Y < 0 then
            NewFrame.Y := 5
          else if NewFrame.Y > 5 then
            NewFrame.Y := 0;
        end;
    else
      FrameIt := FALSE;
    end;
  end else
    NewFrame := Point(1, 1);

  if FrameIt then
    FrameCurrentSquare(NewFrame);
end;

end.