ezcolorpicker.pas

很管用的GIS控件

    // custom color picking
    FCustomColor: TColor;
    procedure SelectColor(Color: TColor);
    procedure ChangeHoverSelection(Index: Integer);
    procedure DrawCell(Index: Integer);
    procedure InvalidateCell(Index: Integer);
    procedure EndSelection(Cancel: Boolean);
    function GetCellRect(Index: Integer; var Rect: TRect): Boolean;
    function GetColumn(Index: Integer): Integer;
    function GetIndex(Row, Col: Integer): Integer;
    function GetRow(Index: Integer): Integer;
    procedure Initialise;
    procedure AdjustWindow;
    procedure SetSpacing(Value: Integer);
    procedure SetSelectedColor(const Value: TColor);
    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
    procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
    procedure CNSysKeyDown(var Message: TWMChar); message CN_SYSKEYDOWN;
    procedure WMActivateApp(var Message: TWMActivateApp); message WM_ACTIVATEAPP;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    function SelectionFromPoint(P: TPoint): Integer;
    function GetHint(Cell: Integer): String;
    procedure DrawSeparator(Left, Top, Right: Integer);
    procedure ChangeSelection(NewSelection: Integer);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure ShowPopupAligned;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    property SelectedColor: TColor read FCurrentColor write SetSelectedColor;
    property Spacing: Integer read FSpacing write SetSpacing;
  end;

var GlyphCache: TGlyphCache;

//----------------- TGlyphList ------------------------------------------------

constructor TGlyphList.CreateSize(AWidth, AHeight: Integer);

begin
  inherited CreateSize(AWidth, AHeight);
  FUsed := TBits.Create;
end;

//-----------------------------------------------------------------------------

destructor TGlyphList.Destroy;

begin
  FUsed.Free;
  inherited Destroy;
end;

//-----------------------------------------------------------------------------

function TGlyphList.AllocateIndex: Integer;

begin
  Result := FUsed.OpenBit;
  if Result >= FUsed.Size then
  begin
    Result := inherited Add(nil, nil);
    FUsed.Size := Result + 1;
  end;
  FUsed[Result] := True;
end;

//-----------------------------------------------------------------------------

function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;

begin
  Result := AllocateIndex;
  ReplaceMasked(Result, Image, MaskColor);
  Inc(FCount);
end;

//-----------------------------------------------------------------------------

procedure TGlyphList.Delete(Index: Integer);

begin
  if FUsed[Index] then
  begin
    Dec(FCount);
    FUsed[Index] := False;
  end;
end;

//----------------- TGlyphCache -----------------------------------------------

constructor TGlyphCache.Create;

begin
  inherited Create;
  FGlyphLists := TList.Create;
end;

//-----------------------------------------------------------------------------

destructor TGlyphCache.Destroy;

begin
  FGlyphLists.Free;
  inherited Destroy;
end;

//-----------------------------------------------------------------------------

function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;

var I: Integer;

begin
  for I := FGlyphLists.Count - 1 downto 0 do
  begin
    Result := FGlyphLists[I];
    with Result do
      if (AWidth = Width) and (AHeight = Height) then Exit;
  end;
  Result := TGlyphList.CreateSize(AWidth, AHeight);
  FGlyphLists.Add(Result);
end;

//-----------------------------------------------------------------------------

procedure TGlyphCache.ReturnList(List: TGlyphList);

begin
  if List = nil then Exit;
  if List.Count = 0 then
  begin
    FGlyphLists.Remove(List);
    List.Free;
  end;
end;

//-----------------------------------------------------------------------------

function TGlyphCache.Empty: Boolean;

begin
  Result := FGlyphLists.Count = 0;
end;

//----------------- TButtonGlyph ----------------------------------------------

constructor TButtonGlyph.Create;

var I: TButtonState;

begin
  inherited Create;
  FOriginal := TBitmap.Create;
  FOriginal.OnChange := GlyphChanged;
  FTransparentColor := clOlive;
  FNumGlyphs := 1;
  for I := Low(I) to High(I) do FIndexes[I] := -1;
  if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
end;

//-----------------------------------------------------------------------------

destructor TButtonGlyph.Destroy;

begin
  FOriginal.Free;
  Invalidate;
  if Assigned(GlyphCache) and GlyphCache.Empty then
  begin
    GlyphCache.Free;
    GlyphCache := nil;
  end;
  inherited Destroy;
end;

//-----------------------------------------------------------------------------

procedure TButtonGlyph.Invalidate;

var I: TButtonState;

begin
  for I := Low(I) to High(I) do
  begin
    if FIndexes[I] <> -1 then FGlyphList.Delete(FIndexes[I]);
    FIndexes[I] := -1;
  end;
  GlyphCache.ReturnList(FGlyphList);
  FGlyphList := nil;
end;

//-----------------------------------------------------------------------------

procedure TButtonGlyph.GlyphChanged(Sender: TObject);

begin
  if Sender = FOriginal then
  begin
    FTransparentColor := FOriginal.TransparentColor;
    Invalidate;
    if Assigned(FOnChange) then FOnChange(Self);
  end;
end;

//-----------------------------------------------------------------------------

procedure TButtonGlyph.SetGlyph(Value: TBitmap);

var Glyphs: Integer;

begin
  Invalidate;
  FOriginal.Assign(Value);
  if (Value <> nil) and (Value.Height > 0) then
  begin
    FTransparentColor := Value.TransparentColor;
    if Value.Width mod Value.Height = 0 then
    begin
      Glyphs := Value.Width div Value.Height;
      if Glyphs > 4 then Glyphs := 1;
      SetNumGlyphs(Glyphs);
    end;
  end;
end;

//-----------------------------------------------------------------------------

procedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);

begin
  if (Value <> FNumGlyphs) and (Value > 0) then
  begin
    Invalidate;
    FNumGlyphs := Value;
    GlyphChanged(Glyph);
  end;
end;

//-----------------------------------------------------------------------------

function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;

const ROP_DSPDxax = $00E20746;

var TmpImage, DDB, MonoBmp: TBitmap;
    IWidth, IHeight: Integer;
    IRect, ORect: TRect;
    I: TButtonState;
    DestDC: HDC;

begin
  if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
  Result := FIndexes[State];
  if Result <> -1 then Exit;
  if (FOriginal.Width or FOriginal.Height) = 0 then Exit;

  IWidth := FOriginal.Width div FNumGlyphs;
  IHeight := FOriginal.Height;
  if FGlyphList = nil then
  begin
    if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
    FGlyphList := GlyphCache.GetList(IWidth, IHeight);
  end;
  TmpImage := TBitmap.Create;
  try
    TmpImage.Width := IWidth;
    TmpImage.Height := IHeight;
    IRect := Rect(0, 0, IWidth, IHeight);
    TmpImage.Canvas.Brush.Color := clBtnFace;
    TmpImage.Palette := CopyPalette(FOriginal.Palette);
    I := State;
    if Ord(I) >= NumGlyphs then I := bsUp;
    ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
    case State of
      bsUp, bsDown,
      bsExclusive:
        begin
          TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
          if FOriginal.TransparentMode = tmFixed then
            FIndexes[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor)
          else
            FIndexes[State] := FGlyphList.AddMasked(TmpImage, clDefault);
        end;
      bsDisabled:
        begin
          MonoBmp := nil;
          DDB := nil;
          try
            MonoBmp := TBitmap.Create;
            DDB := TBitmap.Create;
            DDB.Assign(FOriginal);
            DDB.HandleType := bmDDB;
            if NumGlyphs > 1 then
            with TmpImage.Canvas do
            begin
              // Change white & gray to clBtnHighlight and clBtnShadow
              CopyRect(IRect, DDB.Canvas, ORect);
              MonoBmp.Monochrome := True;
              MonoBmp.Width := IWidth;
              MonoBmp.Height := IHeight;

              // Convert white to clBtnHighlight
              DDB.Canvas.Brush.Color := clWhite;
              MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
              Brush.Color := clBtnHighlight;
              DestDC := Handle;
              SetTextColor(DestDC, clBlack);
              SetBkColor(DestDC, clWhite);
              BitBlt(DestDC, 0, 0, IWidth, IHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);

              // Convert gray to clBtnShadow
              DDB.Canvas.Brush.Color := clGray;
              MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
              Brush.Color := clBtnShadow;
              DestDC := Handle;
              SetTextColor(DestDC, clBlack);
              SetBkColor(DestDC, clWhite);
              BitBlt(DestDC, 0, 0, IWidth, IHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);

              // Convert transparent color to clBtnFace
              DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);
              MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
              Brush.Color := clBtnFace;
              DestDC := Handle;
              SetTextColor(DestDC, clBlack);
              SetBkColor(DestDC, clWhite);
              BitBlt(DestDC, 0, 0, IWidth, IHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
            end
            else
            begin
              // Create a disabled version
              with MonoBmp do
              begin
                Assign(FOriginal);
                HandleType := bmDDB;
                Canvas.Brush.Color := clBlack;
                Width := IWidth;
                if Monochrome then
                begin
                  Canvas.Font.Color := clWhite;
                  Monochrome := False;
                  Canvas.Brush.Color := clWhite;
                end;
                Monochrome := True;
              end;

              with TmpImage.Canvas do
              begin
                Brush.Color := clBtnFace;
                FillRect(IRect);
                Brush.Color := clBtnHighlight;
                SetTextColor(Handle, clBlack);
                SetBkColor(Handle, clWhite);
                BitBlt(Handle, 1, 1, IWidth, IHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
                Brush.Color := clBtnShadow;
                SetTextColor(Handle, clBlack);
                SetBkColor(Handle, clWhite);
                BitBlt(Handle, 0, 0, IWidth, IHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
              end;
            end;
          finally
            DDB.Free;
            MonoBmp.Free;
          end;
          FIndexes[State] := FGlyphList.AddMasked(TmpImage, clDefault);
        end;
    end;
  finally
    TmpImage.Free;
  end;
  Result := FIndexes[State];
  FOriginal.Dormant;
end;

//-----------------------------------------------------------------------------

procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
                                       State: TButtonState; Transparent: Boolean);

var Index: Integer;