写到这,再加上一个选择索引颜色的功能,基本实现我的要求。但控件的还有很多要素还没有加入。比如,对齐属性没有,事件一个也没有。所有的这些将在这里终结,并最后给出所有原码。
用户要设置颜色,就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;
interface
uses
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;
implementation
procedure 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.