dfsclrbn.pas

动态提示控件

    else if PalXY.X + FPaletteForm.Width > ScreenRect.Right then
      { No room to display horizontally, shift left }
      PalXY.X := ScreenRect.Right - 78;
    FPaletteForm.SetBounds(PalXY.X, PalXY.Y, FPaletteForm.Width,
      FPaletteForm.Height);
  {$ELSE}
    if PalXY.Y + FPaletteForm.Height > Screen.Height then
      { No room to display below the button, show it above instead }
      PalXY := Parent.ClientToScreen(Point(Left, Top - 121));
    if PalXY.X < 0 then
      { No room to display horizontally, shift right }
      PalXY.X := 0
    else if PalXY.X + FPaletteForm.Width > Screen.Width then
      { No room to display horizontally, shift left }
      PalXY.X := Screen.Width - 78;
    FPaletteForm.SetBounds(PalXY.X, PalXY.Y, FPaletteForm.Width,
      FPaletteForm.Height);
  {$ENDIF}
    FPaletteForm.ShowColorHints := ShowColorHints;
    FPaletteForm.btnOther.Caption := OtherBtnCaption;
    FPaletteForm.OtherColor := OtherColor;
    FPaletteForm.StartColor := Color;
    FPaletteForm.SetParentColor := PaletteSetColor;
    FPaletteForm.PaletteClosed := PaletteClosed;
    FPaletteForm.PaletteColors := PaletteColors;
    FPaletteForm.CustomColors := CustomColors;
    FPaletteForm.OnGetColorHintText := FOnGetColorHintText;
    FPaletteDisplayed := TRUE;
    Refresh;
    FPaletteForm.Show;
    ParentForm := GetParentForm(Self);
    if ParentForm <> NIL then
      FlashWindow(ParentForm.Handle, TRUE);
  end;
end;

procedure TdfsColorButton.PaletteSetColor(Sender: TObject; IsOther: boolean;
   AColor: TColor);
begin
  Color := AColor;
  if IsOther then
    OtherColor := AColor;
end;

procedure TdfsColorButton.PaletteClosed(Sender: TObject);
var
  CP: TPoint;
  ParentForm: TCustomForm;
begin
  ParentForm := GetParentForm(Self);
  if ParentForm <> NIL then
    FlashWindow(ParentForm.Handle, FALSE);
  if FPaletteForm = NIL then exit;
  if not FPaletteForm.KeyboardClose then
  begin
    GetCursorPos(CP);
    CP := ScreenToClient(CP);
    if (CP.X >= 0) and (CP.X < Width) and (CP.Y >= 0) and (CP.Y < Height) then
      FInhibitClick := TRUE;
  end;
  CustomColors := FPaletteForm.CustomColors;
  FPaletteDisplayed := FALSE;
  Invalidate;
  FPaletteForm := NIL;
  if not FIgnoreTopmosts then
    Application.RestoreTopMosts;
end;

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

procedure TdfsColorButton.SetCustomColors(Value: TCustomColors);
begin
  FCustomColors.Assign(Value);
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 TdfsColorButton.SetDefaultColors;
var
  X, Y: integer;
  DefColors: TColorArrayCallback;
  DC: HDC;
  {$IFNDEF DFS_WIN32}
  CallbackProc: TFarProc;
  {$ENDIF}
begin
  DC := GetDC(GetDesktopWindow);
  try
    if GetDeviceCaps(DC, NUMCOLORS) = 16 then
    begin
      { 16 color mode, enum colors to fill array }
      FillChar(DefColors, SizeOf(DefColors), #0);
      {$IFDEF DFS_WIN32}
      EnumObjects(DC, OBJ_PEN, @ColorEnumProc, LPARAM(@DefColors));
      {$ELSE}
      CallbackProc := MakeProcInstance(@ColorEnumProc, hInstance);
      try
        EnumObjects(DC, OBJ_PEN, CallbackProc, @DefColors);
      finally
        FreeProcInstance(CallbackProc);
      end;
      {$ENDIF}

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

  for x := 1 to 8 do
    for y := 1 to 2 do
      CustomColors[x,y] := clWhite;

  FOtherColor := clBtnFace;
end;


function TdfsColorButton.GetSectionName: string;
begin
  Result := Self.Name;
  if Parent <> NIL then
    Result := Parent.Name + '.' + Result;
end;


procedure TdfsColorButton.SaveCustomColors;
var
  {$IFDEF DFS_WIN32}
  Reg: TRegIniFile;
  {$ELSE}
  Ini: TIniFile;
  {$ENDIF}
  Colors: string;
  x: integer;
  y: integer;
begin
  Colors := '';
  for x := 1 to 8 do
  begin
    for y := 1 to 2 do
    begin
      Colors := Colors + '$' + IntToHex(CustomColors[x,y], 8) + ',';
    end;
  end;
  Delete(Colors, Length(Colors), 1); { strip last comma }

  {$IFDEF DFS_WIN32}
  if FCustomColorsKey <> '' then
  begin
    Reg := TRegIniFile.Create(FCustomColorsKey);
    try
      Reg.WriteString('Colors', FSectionName, Colors);
    finally
      Reg.Free;
    end;
  end;
  {$ELSE}
  if FCustomColorsINI <> '' then
  begin
    Ini := TIniFile.Create(FCustomColorsINI);
    try
      Ini.WriteString('Colors', FSectionName, Colors);
    finally
      Ini.Free;
    end;
  end;
  {$ENDIF}
end;


procedure TdfsColorButton.LoadCustomColors;
var
  {$IFDEF DFS_WIN32}
  Reg: TRegIniFile;
  {$ELSE}
  Ini: TIniFile;
  {$ENDIF}
  Colors: string;
  AColor: string;
  CPos: byte;
  x: integer;
  y: integer;
begin
  Colors := '';
  FSectionName := GetSectionName;
  FColorsLoaded := TRUE;

  {$IFDEF DFS_WIN32}
  if FCustomColorsKey <> '' then
  begin
    Reg := TRegIniFile.Create(FCustomColorsKey);
    try
      Colors := Reg.ReadString('Colors', FSectionName, '');
    finally
      Reg.Free;
    end;
  {$ELSE}
  if FCustomColorsINI <> '' then
  begin
    Ini := TIniFile.Create(FCustomColorsINI);
    try
      Colors := Ini.ReadString('Colors', FSectionName, '');
    finally
      Ini.Free;
    end;
  {$ENDIF}
		if Colors <> '' then
		begin
      x := 1;
      y := 1;
      CPos := Pos(',', Colors);
      while CPos > 0 do
      begin
        AColor := Copy(Colors, 1, CPos-1);
        CustomColors[x,y] := StrToIntDef(AColor, clWhite);
        inc(y);
        if y > 2 then
        begin
          y := 1;
          inc(x);
          if x > 8 then
            break;  { all done }
        end;
        Colors := Copy(Colors, CPos+1, Length(Colors));
      end;    { while }
		end;
  end;
end;


procedure TdfsColorButton.DoColorChange;
begin
  if assigned(FOnColorChange) then
    FOnColorChange(Self);
end;

procedure TdfsColorButton.SetArrowBmp(Value: TBitmap);
begin
  if Value <> NIL then
  begin
    FArrowBmp.Assign(Value);
    Invalidate;
  end;
end;

procedure TdfsColorButton.SetDisabledArrowBmp(Value: TBitmap);
begin
  if Value <> NIL then
  begin
    FDisabledArrowBmp.Assign(Value);
    Invalidate;
  end;
end;

{$IFDEF DFS_WIN32}
procedure TdfsColorButton.SetFlat(Value: boolean);
begin
  if Value <> FFlat then
  begin
    FFlat := Value;
    Invalidate;
  end;
end;

procedure TdfsColorButton.CMMouseEnter(var Message: TMessage);
begin
  if FFlat and (not FIsMouseOver) then
    Invalidate;
end;

procedure TdfsColorButton.CMMouseLeave(var Message: TMessage);
begin
  if FFlat and (FIsMouseOver) then
    Invalidate;
end;
{$ENDIF}

function TdfsColorButton.GetVersion: string;
begin
  Result := DFS_COMPONENT_VERSION;
end;

procedure TdfsColorButton.SetVersion(const Val: string);
begin
  { empty write method, just needed to get it to show up in Object Inspector }
end;

end.