写一个调色板控件（终结）

来源：互联网发布：yonex 网球拍知乎编辑：程序博客网时间：2024/06/06 23:59

写到这，再加上一个选择索引颜色的功能，基本实现我的要求。但控件的还有很多要素还没有加入。比如，对齐属性没有，事件一个也没有。所有的这些将在这里终结，并最后给出所有原码。

用户要设置颜色，就windows来说：就鼠标是左键点击。那么这里就得先增加几个变量，方便程序处理：
FMRect: array [0 .. 32 * 32] of TRect; //所有的小正方形所在区域
FColorIndex： Integer； //选择颜色序号
FX, FY: Integer; //鼠标坐标
当然，要处理鼠标移动和点击。

  private    ……    FMRect: array [0 .. 32 * 32] of TRect;  //所有的小正方形所在区域    FColorIndex: Integer;  //选择颜色序号    FX, FY: Integer;    //鼠标坐标    procedure MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;    procedure SetColorIndex(const Value: Integer);  published    ……    property ColorIndex: Integer read FColorIndex write SetColorIndex;    ……implementation  ……procedure TPaletteBoxVCL.MouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);begin  FX := X;  FY := Y;end;procedure TPaletteBoxVCL.WMLButtonDown(var Message: TWMLButtonDown);var  i: Integer;  R: TRect;begin  for i := 0 to 32 * 32 - 1 do begin    if FMRect[i].Contains(Point(FX, FY)) then begin      FColorIndex := i;      break;    end;  end;  inherited;end;procedure TPaletteBoxVCL.SetColorIndex(const Value: Integer);begin  FColorIndex := Value;  Paint;end;

画出选择的小正方形，也就是矩形上、左两边画白色，右、下两边画上深灰色，视觉效果就会突起：

procedure TPaletteBoxVCL.Paint;……      for j := 0 to Col - 1 do begin        FMRect[A] := R;        if A = FColorIndex then          IR := R; // 索引色 RECT……              if FColorIndex<>-1 then begin      Canvas.Pen.Color := clwhite;      Canvas.MoveTo(IR.Left, IR.Top);      Canvas.LineTo(IR.Right - FInterval, IR.Top);      Canvas.MoveTo(IR.Left, IR.Top);      Canvas.LineTo(IR.Left, IR.Bottom - FInterval);      Canvas.Pen.Color := $A0A0A0;      Canvas.MoveTo(IR.Right - FInterval, IR.Top);      Canvas.LineTo(IR.Right - FInterval, IR.Bottom);      Canvas.MoveTo(IR.Left, IR.Bottom);      Canvas.LineTo(IR.Right - FInterval, IR.Bottom);    end;  end;  Canvas.Draw(0, 0, BMP);  BMP.Free;end;

突起效果

现在，只需实现最后一个功能：Tile用的是哪8个索引色。在写这个文章过程中，朋友提出看不太清楚程序的提示，特别是更改索引文件后。于是又加了一堆代码，实现象Ps选择区域那样的蚂蚁线，动态，且不受颜色影响，那就醒目多了，如下图：
对比图片动起来的效果更明显

参考试Ps的蚂蚁线，每根黑线或白钱长度为6，动作步骤为3步，每步移动两个象素。
Ps好象有两种动画画蚂蚁线，我这里只写了顺时钟旋转那种植，矩形转角时，颜色的连续和象素的连续不完美，将就着就用了。直接代码，不啰嗦了。

unit PaletteBoxVCL;interfaceuses  System.SysUtils, System.Classes, Vcl.Controls, Vcl.ExtCtrls, System.math,  Winapi.Messages, Winapi.windows, Vcl.Graphics;type  TRGBColor = packed record    case Integer of      0: (R, G, B, A: Byte;        );      1: (C: Dword);  end;  TPaletteBoxVCL = class(TGraphicControl)  private    FPaletteBin: array [0 .. 32 * 32 - 1] of TRGBColor;    FCanDraw: boolean;    FPalCount: Integer;    FCol: Integer;    FRow: Integer;    FInterval: Integer;    FShowTile: boolean;    FMRect: array [0 .. 32 * 32] of TRect; // 所有的小正方形所在区域    FColorIndex: Integer; // 选择颜色序号    FX, FY: Integer;      // 鼠标坐标(*画蚂蚁线变量*)    FTime: TTimer;    FShowIndexRect: Integer;   //Tile 8色索引位置    FFlowRect:TRect;           //画蚂蚁线的 RECT    FFlowStep: Integer;        //动画步骤    FlowEndColor: TColor;      //黑白色控件变量（****）    procedure SetCol(const Value: Integer);    procedure SetRow(const Value: Integer);    procedure SetInterva(const Value: Integer);    procedure SetShowTile(const Value: boolean);    procedure MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;    procedure SetColorIndex(const Value: Integer);    procedure SetShowIndexRect(const Value: Integer);    procedure OnTimer(Sender: TObject);  protected    procedure Paint; override;  public    constructor Create(AOwner: TComponent); override;    destructor Destroy; override;    procedure SetColor(index: Integer; Color: Dword);    function GetColor(index: Integer): TRGBColor;    procedure BeginUpdate;    procedure EndUpdate;  published    property Align;    property Col: Integer read FCol write SetCol;    property Row: Integer read FRow write SetRow;    property Interval: Integer read FInterval write SetInterva;    property ShowTile: boolean read FShowTile write SetShowTile;    property ColorIndex: Integer read FColorIndex write SetColorIndex;    property ShowIndexRect: Integer read FShowIndexRect write SetShowIndexRect;    property OnClick;    property OnDblClick;  end;procedure Register;implementationprocedure Register;begin  RegisterComponents('redsky', [TPaletteBoxVCL]);end;{ TPaletteBoxVCL }constructor TPaletteBoxVCL.Create(AOwner: TComponent);begin  inherited Create(AOwner);  FCanDraw := true;  FCol := 16;  FRow := 16;  FInterval := 2;  FShowTile := true;  FColorIndex := -1;  FFlowRect:=RECT(0,0,0,0);  FlowEndColor := clBlack;  FFlowStep := 0;  FTime := TTimer.Create(self);  FTime.Enabled := true;  FTime.Interval := 200;  FTime.OnTimer := OnTimer;end;destructor TPaletteBoxVCL.Destroy;begin  FTime.OnTimer := nil;  FTime.Enabled:=false;  FTime.Free;  inherited;end;procedure TPaletteBoxVCL.Paint;  function RGBtoColor(R, G, B: Byte): TColor;  begin    result := TColor((B shl 16) + (G shl 8) + R);  end;var  i, j, A: Integer;  Pw, Ph: Integer;  R, IR: TRect;  BMP: TBitmap;begin  if not FCanDraw then exit;  BMP := TBitmap.Create; // 防闪烁  BMP.Width := Width;  BMP.Height := Height;  Pw := (Width - FInterval) div FCol; // 留边 2Pix  Ph := (Height - FInterval) div FRow;  Pw := min(Pw, Ph);  Pw := Pw - FInterval; // 相距 2PIX  Ph := Pw;  with BMP do begin    Canvas.Pen.Color := clGray;    Canvas.Brush.Color := clbtnFace;    Canvas.Rectangle(0, 0, Width, Height);    Canvas.Brush.Color := clGray;    Canvas.Pen.Width := 1;    A := 0;    for i := 0 to Row - 1 do begin      R := RECT(0, 0, Pw, Ph);      R.Offset(FInterval, FInterval);      R.Offset(0, i * (Ph + FInterval));      for j := 0 to Col - 1 do begin        FMRect[A] := R;        if A = FColorIndex then          IR := R; // 索引色 RECT         if (A = FShowIndexRect) then begin // 画蚂蚁线 RECT          FFlowRect := TRect.Create(R);          FFlowRect.Right := FFlowRect.Left + 8 * (Pw + FInterval); //每个Tile 8种颜色          FFlowRect.Right := FFlowRect.Right - 1;          FFlowRect.Left := R.Left - 1;          FFlowRect.Top := FFlowRect.Top - 1;          FFlowRect.Bottom := FFlowRect.Bottom + 1;        end;        Canvas.Pen.Color := clGray;        Canvas.Brush.Color := RGBtoColor(FPaletteBin[A].R, FPaletteBin[A].G, FPaletteBin[A].B);        if FInterval > 0 then          Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom)        else begin // 间隔为 0 ，画线，          Canvas.FillRect(RECT(R.Left + 1, R.Top + 1, R.Right, R.Bottom));          if i = 0 then begin // 顶上一根线            Canvas.MoveTo(R.Left, R.Top);            Canvas.LineTo(R.Right, R.Top);          end;          if j = 0 then begin            Canvas.MoveTo(R.Left, R.Top);            Canvas.LineTo(R.Left, R.Bottom);          end;          Canvas.MoveTo(R.Left, R.Bottom);          Canvas.LineTo(R.Right, R.Bottom);          Canvas.MoveTo(R.Right, R.Top);          Canvas.LineTo(R.Right, R.Bottom);        end;        R.Offset(Pw + FInterval, 0);        inc(A);      end;    end;    if (FInterval = 0) and FShowTile then begin      Canvas.Pen.Width := 2;      Canvas.Pen.Color := clGray;      for i := 1 to (FCol div 8) - 1 do begin        Canvas.MoveTo(i * 8 * Pw, 0);        Canvas.LineTo(i * 8 * Pw, Ph * FRow);      end;      for i := 1 to (FRow div 8) - 1 do begin        Canvas.MoveTo(0, i * 8 * Ph);        Canvas.LineTo(Ph * Col, i * 8 * Ph);      end;    end;    if FColorIndex<>-1 then begin      Canvas.Pen.Color := clwhite;      Canvas.MoveTo(IR.Left, IR.Top);      Canvas.LineTo(IR.Right - FInterval, IR.Top);      Canvas.MoveTo(IR.Left, IR.Top);      Canvas.LineTo(IR.Left, IR.Bottom - FInterval);      Canvas.Pen.Color := $A0A0A0;      Canvas.MoveTo(IR.Right - FInterval, IR.Top);      Canvas.LineTo(IR.Right - FInterval, IR.Bottom);      Canvas.MoveTo(IR.Left, IR.Bottom);      Canvas.LineTo(IR.Right - FInterval, IR.Bottom);    end;  end;  Canvas.Draw(0, 0, BMP);  BMP.Free;end;function TPaletteBoxVCL.GetColor(index: Integer): TRGBColor;begin  result := FPaletteBin[Index];end;procedure TPaletteBoxVCL.SetColor(index: Integer; Color: Dword);begin  FPaletteBin[index].C := Color;  Paint;end;procedure TPaletteBoxVCL.SetInterva(const Value: Integer);begin  if Value >= 0 then begin    FInterval := Value;    Paint;  end;end;procedure TPaletteBoxVCL.SetCol(const Value: Integer);begin  if Value > 0 then begin    if (Value * FRow) <= 1024 then begin      FCol := Value;      FPalCount := FCol * FRow;      Paint;    end;  end;end;procedure TPaletteBoxVCL.SetRow(const Value: Integer);begin  if Value > 0 then begin    if (FCol * Value) <= 1024 then begin      FRow := Value;      FPalCount := FCol * FRow;      Paint;    end;  end;end;procedure TPaletteBoxVCL.SetShowTile(const Value: boolean);begin  FShowTile := Value;  Paint;end;procedure TPaletteBoxVCL.BeginUpdate;begin  FCanDraw := false;end;procedure TPaletteBoxVCL.EndUpdate;begin  FCanDraw := true;  Paint;end;procedure TPaletteBoxVCL.MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);begin  FX := X;  FY := Y;end;procedure TPaletteBoxVCL.WMLButtonDown(var Message: TWMLButtonDown);var  i: Integer;  R: TRect;begin  for i := 0 to 32 * 32 - 1 do begin    if FMRect[i].Contains(Point(FX, FY)) then begin      FColorIndex := i;      break;    end;  end;  inherited;end;procedure TPaletteBoxVCL.SetColorIndex(const Value: Integer);begin  FColorIndex := Value;  Paint;end;procedure TPaletteBoxVCL.SetShowIndexRect(const Value: Integer);begin  FShowIndexRect := Value;  Paint;end;procedure TPaletteBoxVCL.OnTimer(Sender: TObject);  procedure DrawFlowLine(Canvas: Tcanvas; P1, P2: TPoint; Step: Integer);  //画蚂蚁线  var    i: Integer;    A, B: Integer;    P: TPoint;    bb: boolean;  begin    if P1.X = P2.X then begin      if P2.Y > P1.Y then A := P1.Y + Step * 2      else A := P1.Y - Step * 2;      Canvas.Pen.Color := FlowEndColor;      Canvas.MoveTo(P1.X, P1.Y);      Canvas.LineTo(P2.X, A);      i := 0;      repeat        inc(i);        case i mod 2 of          0: Canvas.Pen.Color := FlowEndColor;          1: Canvas.Pen.Color := ColorToRGB(FlowEndColor) xor $FFFFFF;        end;        B := A;        if P2.Y > P1.Y then A := min(P2.Y, A + 6)        else A := max(P2.Y, A - 6);        Canvas.MoveTo(P1.X, B);        Canvas.LineTo(P2.X, A);        if P2.Y > P1.Y then bb := A >= P2.Y        else bb := A <= P2.Y;      until bb;    end;    if P1.Y = P2.Y then begin      if P2.X > P1.X then A := P1.X + Step * 2      else A := P1.X - Step * 2;      Canvas.Pen.Color := FlowEndColor;      Canvas.MoveTo(P1.X, P1.Y);      Canvas.LineTo(A, P2.Y);      i := 0;      repeat        inc(i);        case i mod 2 of          0: Canvas.Pen.Color := FlowEndColor;          1: Canvas.Pen.Color := ColorToRGB(FlowEndColor) xor $FFFFFF;        end;        B := A;        if P2.X > P1.X then A := min(P2.X, A + 6)        else A := max(P2.X, A - 6);        Canvas.MoveTo(B, P1.Y);        Canvas.LineTo(A, P2.Y);        if P2.X > P1.X then bb := A >= P2.X        else bb := A <= P2.X;      until bb;    end;  end;  procedure DrawFlowRECT(Canvas: Tcanvas; R: TRect);   //画矩形  begin    DrawFlowLine(Canvas, R.TopLeft, Point(R.Right, R.Top), FFlowStep);    DrawFlowLine(Canvas, Point(R.Right, R.Top), R.BottomRight, FFlowStep);    DrawFlowLine(Canvas, R.BottomRight, Point(R.Left, R.Bottom), FFlowStep);    DrawFlowLine(Canvas, Point(R.Left, R.Bottom), R.TopLeft, FFlowStep);  end;begin  if FShowIndexRect=-1 then exit;  inc(FFlowStep);  FFlowStep := FFlowStep mod 3;  if FFlowStep = 0 then  FlowEndColor := ColorToRGB(FlowEndColor) xor $FFFFFF;  DrawFlowRECT(Canvas,FFlowRect);end;end.

阅读全文

0 0