iwtmscolorpicker.pas.~2~

TMS IntraWEb增强控件TMSIntraWeb_v2.3.2.1_D2007.rar

{***************************************************************************}
{ TMS IntraWeb Component Pack Pro                                           }
{ for Delphi & C++Builder                                                   }
{ version 2.2                                                               }
{                                                                           }
{ written by TMS Software                                                   }
{            copyright ?2002 - 2004                                        }
{            Email : [e-mail]                                   }
{            Web : http://www.tmssoftware.com                               }
{                                                                           }
{ The source code is given as is. The author is not responsible             }
{ for any possible damage done due to the use of this code.                 }
{ The component can be freely used in any application. The complete         }
{ source code remains property of the author and may not be distributed,    }
{ published, given or sold in any form as such. No parts of the source      }
{ code can be included in any other component or application without        }
{ written authorization of the author.                                      }
{***************************************************************************}

unit IWTMSColorPicker;

{$I TMSDEFS.INC}

interface                                

uses
  {$IFDEF LINUX}
  QControls, QGraphics,
  {$ELSE}
  Controls, Windows, Graphics,
  {$ENDIF}
  {$IFDEF DELPHI6_LVL}
  Types,
  {$ENDIF}
  Classes,
  IWControl, IWTypes, SysUtils, IWTMSBase,
  IWHTMLTag, IWFont
  {$IFDEF TMSIW6}
  , IWRenderContext, IWColor
  {$ENDIF}
  ;

type
  TColorChangeEvent = procedure(Sender:Tobject;index:byte;ColorChanged:TColor) of object;

  TIWColors = class(Tpersistent)
  private
    FOnColorChange: TcolorChangeEvent;
    procedure Setcolor1(const Value: Tcolor);
    procedure Setcolor10(const Value: Tcolor);
    procedure Setcolor11(const Value: Tcolor);
    procedure Setcolor12(const Value: Tcolor);
    procedure Setcolor13(const Value: Tcolor);
    procedure Setcolor14(const Value: Tcolor);
    procedure Setcolor15(const Value: Tcolor);
    procedure Setcolor16(const Value: Tcolor);
    procedure Setcolor2(const Value: Tcolor);
    procedure Setcolor3(const Value: Tcolor);
    procedure Setcolor4(const Value: Tcolor);
    procedure Setcolor5(const Value: Tcolor);
    procedure Setcolor6(const Value: Tcolor);
    procedure Setcolor7(const Value: Tcolor);
    procedure Setcolor8(const Value: Tcolor);
    procedure Setcolor9(const Value: Tcolor);
  protected
    FColor1:Tcolor;
    FColor2:Tcolor;
    FColor3:Tcolor;
    FColor4:Tcolor;
    FColor5:Tcolor;
    FColor6:Tcolor;
    FColor7:Tcolor;
    FColor8:Tcolor;
    FColor9:Tcolor;
    FColor10:Tcolor;
    FColor11:Tcolor;
    FColor12:Tcolor;
    FColor13:Tcolor;
    FColor14:Tcolor;
    FColor15:Tcolor;
    FColor16:Tcolor;
    procedure Dochange(index:byte;ColorChanged:Tcolor);
  public
    constructor Create;
  published
    property Color1 : Tcolor read FColor1   write Setcolor1   default clBlack;
    property Color2 : Tcolor read FColor2   write Setcolor2   default clMaroon;
    property Color3 : Tcolor read FColor3   write Setcolor3   default clGreen;
    property Color4 : Tcolor read FColor4   write Setcolor4   default clOlive;
    property Color5 : Tcolor read FColor5   write Setcolor5   default clNavy;
    property Color6 : Tcolor read FColor6   write Setcolor6   default clPurple;
    property Color7 : Tcolor read FColor7   write Setcolor7   default clTeal;
    property Color8 : Tcolor read FColor8   write Setcolor8   default clSilver;
    property Color9 : Tcolor read FColor9   write Setcolor9   default clGray;
    property Color10:Tcolor  read  FColor10 write Setcolor10 default clRed;
    property Color11:Tcolor  read  FColor11 write Setcolor11 default clLime;
    property Color12:Tcolor  read  FColor12 write Setcolor12 default clYellow;
    property Color13:Tcolor  read  FColor13 write Setcolor13 default clBlue;
    property Color14:Tcolor  read  FColor14 write Setcolor14 default clFuchsia;
    property Color15:Tcolor  read  FColor15 write Setcolor15 default clAqua;
    property Color16:Tcolor  read  FColor16 write Setcolor16 default clWhite;
    Property OnColorChange: TColorChangeEvent read FOnColorChange write FOnColorChange;
  end;

  TIWTMSButton = class(TPersistent)
  private
    FCaption: string;
    FWidth: Word;
    FHeight: Word;
    FFont: TIWFont;
    FOnButtonChange: TNotifyEvent;
    FColor: TColor;
    procedure SetCaption(const Value: String);
    procedure SetHeight(const Value: Word);
    procedure SetWidth(const Value: Word);
    procedure SetFont(const Value: TIWFont);
    procedure FontChanged(Sender: TObject);
    procedure DoButtonChange;
    procedure SetColor(const Value: TColor);
  public
    constructor Create;
    destructor Destroy;override;
  published
    property Caption: string read FCaption write SetCaption;
    property Color: TColor read FColor write SetColor default clBtnFace;
    property Width: word read  FWidth write  SetWidth default 75;
    property Height: word read FHeight write SetHeight  default 25;
    property Font: TIWFont read FFont write SetFont;
    property OnButtonChange: TNotifyEvent read FOnButtonChange write FOnButtonChange;
  end;

  TTIWCustomColorPicker = class(TIWControl)
  private
    FLineWidth: byte;
    FColors: TIWColors;
    FColor: TColor;
    FLineColor: TColor;
    FOnColorChanged: TNotifyEvent;
    FPickerVisible: boolean;
    FPreviewVisible: boolean;
    FRowCount: Word;
    FColCount: Word;
    FRectHeight: Word;
    FDefaultColWidth: Word;
    FDefaultRowHeight: Word;
    procedure SetColor(const Value: TColor);
    procedure SetLineColor(const Value: TColor);
    procedure SetLineWidth(const Value: byte);
    procedure SetOnColorChanged(const Value: TNotifyEvent);
    procedure SetColors(x, y: word; const Value: TColor);
    function  GetColors(x, y: word): TColor;
    procedure SetColCount(const Value: Word);
    procedure SetPickerVisible(const Value: boolean);
    procedure SetPreviewVisible(const Value: boolean);
    procedure SetRowCount(const Value: Word);
    procedure SetRectHeight(const Value: Word);
    procedure SetDefaultColWidth(const Value: Word);
    procedure SetDefaultRowHeight(const Value: Word);
    function ColorIndex(Color: TColor): Integer;
    { Private declarations }
  protected
    ColorArray:array of TColor;
    procedure DoColorChanged;
    procedure MoveColors(newColCount:Word);
    procedure HTMLColorChange(index:word);overload;
    procedure HTMLColorChange(x,y:word);overload;
    procedure Submit(const AValue: string); override;
    procedure SetValue(const Avalue: string); override;
    function  HTMLClr(color: TColor):string;
    procedure OnFirstColorsChange(Sender:Tobject;index:byte;ColorChanged:Tcolor);
  public
    Constructor Create(AOwner: TComponent);override;
    Destructor Destroy;override;
    {$IFDEF TMSIW6}
    procedure RenderCustomHTML(var html,picker:string;widthControl:Word; AContext: TIWBaseComponentContext);
    {$ELSE}
    procedure RenderCustomHTML(var html,picker:string;widthControl:Word);
    {$ENDIF}
    property  PaletteColors[x,y:word]: TColor read GetColors write SetColors;
    property ColCount:Word read FColCount write SetColCount default 4;
    property RowCount:Word read FRowCount write SetRowCount default 4;
  published
    Property Colors: TIWColors read FColors write FColors;
    property LineColor: TColor read FLineColor write SetLineColor default clGray;
    property LineWidth: byte read FLineWidth write SetLineWidth default 1;
    property Color: TColor read FColor write SetColor default clWhite;
    property RectHeight: word read FRectHeight write SetRectHeight;
    property PickerVisible: Boolean read FPickerVisible write SetPickerVisible default false;
    property PreviewVisible: Boolean read FPreviewVisible write SetPreviewVisible default true;
    property DefaultColWidth: word read FDefaultColWidth write SetDefaultColWidth;
    property DefaultRowHeight: word read FDefaultRowHeight write SetDefaultRowHeight;
    property OnColorChanged: TNotifyEvent read FOnColorChanged write SetOnColorChanged;
  end;

  TTIWColorPicker = class(TTIWCustomColorPicker)
  private
    FButton: TIWTMSButton;
  protected
    procedure AdjustSize; override;
    procedure DrawButton;
    procedure DrawRect;
    procedure DrawPicker;
    Procedure ButtonChange(Sender:Tobject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    {$IFDEF TMSIW6}
    procedure IWPaint; override;
    function  RenderHTML(AContext: TIWBaseComponentContext): TIWHTMLTag; override;
    {$ELSE}
    procedure Paint; override;
    function  RenderHtml: TIWHTMLTag; override;
    {$ENDIF}
  published
    property Button: TIWTMSButton read FButton write FButton;
    property LineColor;
    property LineWidth;
    property Color;
    property RectHeight;
    property PickerVisible;
    property PreviewVisible;
    property DefaultColWidth;
    property DefaultRowHeight;
    property OnColorChanged;
  end;

implementation

uses
  IWApplication, IWServerControllerBase,
  SWStrings, SWSystem, IWAppForm, Math;

const
  tagcol='Color';


{ TTIWCustomColorPicker }

constructor TTIWCustomColorPicker.Create(AOwner: TComponent);
begin
  inherited;
  {$IFDEF TMSIW6}
  {TODO}
  {$ELSE}
  FSupportsInput := True;
  FSupportsSubmit := True;
  {$ENDIF}
  FLineColor := clGray;
  FLineWidth := 1;
  FColor := clWhite;
  FPickerVisible := False;
  FPreviewVisible := true;
  FRectHeight := 25;
  Width := 75;
  Height := 50;
  FColCount := 4;
  FRowCount := 4;
  FDefaultColWidth := 25;
  FDefaultRowHeight := 25;
  FOnColorChanged := nil;
  SetLength(ColorArray,16);
  FColors := TIWColors.Create;
  ColorArray[0] := clBlack;
  ColorArray[1] := clMaroon;
  ColorArray[2] := clGreen;
  ColorArray[3] := clOlive;
  ColorArray[4] := clNavy;
  ColorArray[5] := clPurple;
  ColorArray[6] := clTeal;
  ColorArray[7] := clSilver;
  ColorArray[8] := clGray;
  ColorArray[9] := clRed;
  ColorArray[10] := clLime;
  ColorArray[11] := clYellow;
  ColorArray[12] := clBlue;
  ColorArray[13] := clFuchsia;
  ColorArray[14] := clAqua;
  ColorArray[15] := clWhite;
  Colors.OnColorChange := OnFirstColorsChange;
end;

destructor TTIWCustomColorPicker.Destroy;
begin
  Finalize(ColorArray);
  FreeandNil(FColors);
  inherited;
end;

function TTIWCustomColorPicker.GetColors(x, y: word): TColor;
var
  i: Integer;
begin
  i := y * FColCount + x;
  if i >= FColCount * FRowCount then
    Result := clNone
  else
    Result := ColorArray[i];
end;

procedure TTIWCustomColorPicker.SetColor(const Value: TColor);
begin
  FColor := Value;
  DoColorChanged;
  Invalidate;
end;

procedure TTIWCustomColorPicker.SetColors(x, y: word; const Value: TColor);
var
  i:Integer;
begin
  i := y * FColCount + x;
  if i < FColCount * FRowCount then
    ColorArray[i-1] := Value;
  Invalidate;
end;

procedure TTIWCustomColorPicker.SetColCount(const Value: Word);
begin
  if FColCount = Value then
    Exit;
  MoveColors(Value);
  FColCount := Value;
  Invalidate;
end;

procedure TTIWCustomColorPicker.SetLineColor(const Value: TColor);
begin
  if FLineColor = Value then
    Exit;
  FLineColor := Value;
  Invalidate;
end;

procedure TTIWCustomColorPicker.SetLineWidth(const Value: byte);
begin
  if FLineWidth = Value then
    Exit;
  FLineWidth := Value;
  Invalidate;
end;

procedure TTIWCustomColorPicker.SetOnColorChanged(const Value: TNotifyEvent);
begin
  FOnColorChanged := Value;
end;


procedure TTIWCustomColorPicker.SetPickerVisible(const Value: boolean);
begin
  if FPickerVisible = Value then
    Exit;
  FPickerVisible := Value;
  Invalidate;
end;

procedure TTIWCustomColorPicker.SetPreviewVisible(const Value: boolean);
begin
  if FPreviewVisible = Value then
    Exit;
  FPreviewVisible := Value;
  Invalidate;
end;

procedure TTIWCustomColorPicker.SetRowCount(const Value: Word);
begin
  if FRowCount = Value then
    Exit;
  FRowCount := Value;
  SetLength(ColorArray,FColCount*FRowCount);
  Invalidate;
end;

procedure TTIWCustomColorPicker.DoColorChanged;
begin
  if Assigned(FOnColorChanged)
    then FOnColorChanged(self);
end;