{----------------------------------------------------------------------------- The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/MPL-1.1.html Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is: JvArrayButton.PAS, released on 2002-06-15. The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl] Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven. All Rights Reserved. Contributor(s): Robert Love [rlove att slcdug dott org]. You may retrieve the latest version of this file at the Project JEDI's JVCL home page, located at http://jvcl.delphi-jedi.org Known Issues: -----------------------------------------------------------------------------} // $Id: JvArrayButton.pas 13473 2012-11-12 23:11:22Z jfudickar $ unit JvArrayButton; {$I jvcl.inc} interface uses {$IFDEF UNITVERSIONING} JclUnitVersioning, {$ENDIF UNITVERSIONING} Windows, Messages, Classes, Graphics, Controls, Forms, Types, JvComponent, JvTypes; type TArrayButtonClicked = procedure(ACol, ARow: Integer) of object; {$IFDEF RTL230_UP} [ComponentPlatformsAttribute(pidWin32 or pidWin64)] {$ENDIF RTL230_UP} TJvArrayButton = class(TJvGraphicControl) private FBmp: TBitmap; FPtDown: TPoint; FPushDown: Boolean; FDown: Boolean; FColor: TColor; FRows: Integer; FCols: Integer; FOnArrayButtonClicked: TArrayButtonClicked; FCaptions: TStringList; FColors: TStringList; FHints: THintStringList; FEnableds: array of Boolean; FDowns: array of Boolean; {$IFDEF JVCLThemesEnabled} FMouseOverBtn: TPoint; FThemed: Boolean; procedure SetThemed(Value: Boolean); {$ENDIF JVCLThemesEnabled} function GetCaptions: TStrings; function GetColors: TStrings; procedure SetCols(const Value: Integer); procedure SetRows(const Value: Integer); procedure SetCaptions(const Value: TStrings); procedure SetColors(const Value: TStrings); procedure MouseToCell(const X, Y: Integer; var ACol, ARow: Integer); function CellRect(ACol, ARow: Integer): TRect; procedure SetHints(const Value: THintStringList); function GetEnableds(Index: Integer): Boolean; procedure SetEnableds(Index: Integer; const Value: Boolean); function GetDowns(Index: Integer): Boolean; procedure SetDowns(Index: Integer; const Value: Boolean); protected procedure FontChanged; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; {$IFDEF JVCLThemesEnabled} procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseEnter(AControl: TControl); override; procedure MouseLeave(AControl: TControl); override; {$ENDIF JVCLThemesEnabled} procedure Paint; override; procedure SizeChanged; dynamic; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; {this procedure can be used in response to a Application.OnShowHint event button hints are stored in the hints property from array top-left to array bottom right in your application create a seperate OnShowHint event Handler within that Handler test HintInfo.HintControl is this object. If it is dispatch to this objects doShowHint. In the FormCreate event handler include: Application.OnShowHint := DrawHint; procedure TDrawF.DrawHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); begin if HintInfo.HintControl = JvArrayButton1 then JvArrayButton1.DoShowHint(HintStr, CanShow, HintInfo); end; I could have set the Application.OnShowHint handler directly in this component, but if you have more components that do this then only the last one would work } procedure DoShowHint(var HintStr: THintString; var CanShow: Boolean; var HintInfo: THintInfo); // A list of individual button Enabled state, from the top-left to the bottom-right button property Enableds[Index: Integer]: Boolean read GetEnableds write SetEnableds; property Downs[Index: Integer]: Boolean read GetDowns write SetDowns; published property Align; property Anchors; property Rows: Integer read FRows write SetRows; property Cols: Integer read FCols write SetCols; {A List of button captions from the top-left to the bottom-right button} property Captions: TStrings read GetCaptions write SetCaptions; property Enabled; property Font; property Height default 35; {A List of button hints from the top-left to the bottom-right button} property Hints: THintStringList read FHints write SetHints; {A List of button Colors from the top-left to the bottom-right button values must be standard Delphi Color names like clRed, clBlue or hex Color strings like $0000ff for red. please note the hex order in Delphi is BGR i.s.o. the RGB order you may know from HTML hex Color triplets} property Colors: TStrings read GetColors write SetColors; {$IFDEF RTL240_UP} [Default(False)] // for proper XE3 IDE work {$ENDIF RTL240_UP} property CanDown: Boolean read FDown write FDown default False; property Hint; property ShowHint default True; {$IFDEF JVCLThemesEnabled} property Themed: Boolean read FThemed write SetThemed default False; {$ENDIF JVCLThemesEnabled} property Visible; property Width default 35; {provides you with the Column and Row of the clicked button the topleft button has Column=0 and Row=0} property OnArrayButtonClicked: TArrayButtonClicked read FOnArrayButtonClicked write FOnArrayButtonClicked; property OnCanResize; property OnMouseDown; {$IFDEF COMPILER9_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF COMPILER9_UP} property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnResize; end; {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( RCSfile: '$URL: http://jvcl.svn.sourceforge.net/svnroot/jvcl/trunk/jvcl/run/JvArrayButton.pas $'; Revision: '$Revision: 13473 $'; Date: '$Date: 2012-11-13 00:11:22 +0100 (Tue, 13 Nov 2012) $'; LogPath: 'JVCL\run' ); {$ENDIF UNITVERSIONING} implementation uses ExtCtrls, Buttons, JvJCLUtils, JvThemes; constructor TJvArrayButton.Create(AOwner: TComponent); begin inherited Create(AOwner); FBmp := TBitmap.Create; Width := 35; Height := 35; FColor := clSilver; FPushDown := False; FCols := 1; FRows := 1; ShowHint := True; FCaptions := TStringList.Create; FHints := THintStringList.Create; FColors := TStringList.Create; {$IFDEF JVCLThemesEnabled} FThemed := False; FMouseOverBtn := Point(-1, -1); {$ENDIF JVCLThemesEnabled} end; destructor TJvArrayButton.Destroy; begin FCaptions.Free; FHints.Free; FColors.Free; SetLength(FEnableds, 0); FBmp.Free; inherited Destroy; end; procedure TJvArrayButton.MouseToCell(const X, Y: Integer; var ACol, ARow: Integer); var DH, DW: Integer; begin DH := (Height - 2) div Rows; DW := (Width - 2) div Cols; ACol := X div DW; ARow := Y div DH; end; procedure TJvArrayButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Col, Row: Integer; Index: Integer; begin if Button = mbLeft then begin MouseToCell(X, Y, Col, Row); Index := Row * Cols + Col; if FEnableds[Index] then begin FPushDown := True; if FDown then FDowns[Index] := not FDowns[Index]; FPtDown := Point(Col, Row); Invalidate; end; end; end; procedure TJvArrayButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Button = mbLeft) and FPushDown then begin if FEnableds[FPtDown.Y * Cols + FPtDown.X] then begin FPushDown := False; Invalidate; if Assigned(FOnArrayButtonClicked) then OnArrayButtonClicked(FPtDown.X, FPtDown.Y); end; end end; {$IFDEF JVCLThemesEnabled} procedure TJvArrayButton.MouseMove(Shift: TShiftState; X, Y: Integer); var Pt: TPoint; begin inherited MouseMove(Shift, X, Y); MouseToCell(X, Y, Pt.X, Pt.Y); if (not FPushDown) and ((Pt.X <> FMouseOverBtn.X) or (Pt.Y <> FMouseOverBtn.Y)) then begin FMouseOverBtn := Pt; Invalidate; end; end; procedure TJvArrayButton.MouseEnter(AControl: TControl); begin inherited MouseEnter(AControl); Invalidate; end; procedure TJvArrayButton.MouseLeave(AControl: TControl); begin inherited MouseLeave(AControl); Invalidate; end; {$ENDIF JVCLThemesEnabled} procedure TJvArrayButton.Paint; var R: TRect; Col, Row: Integer; DH, DW: Integer; X0, Y0: Integer; Cap: string; BackColor: TColor; Index: Integer; l: Integer; procedure DrawThemedBkgrnd(ACanvas: TCanvas; ARect: TRect); var rc:TRect; begin ACanvas.Brush.Color := Color; rc := ARect; InflateRect(rc, 1, 1); SetBkMode(ACanvas.Handle, Windows.TRANSPARENT); ACanvas.FillRect(rc); end; procedure DrawBackground(AColor: TColor; ACanvas: TCanvas); begin ACanvas.Brush.Color := AColor; DrawThemedBackground(Self, ACanvas, R); end; procedure DrawUp(ACanvas: TCanvas); begin {$IFDEF JVCLThemesEnabled} if Themed and StyleServices.Enabled then begin DrawThemedBkgrnd(ACanvas, R); R := DrawThemedButtonFace(Self, ACanvas, R, 0, bsAutoDetect, False, False, False, PtInRect(R, ScreenToClient(Mouse.CursorPos))); SetBkMode(ACanvas.Handle, Windows.TRANSPARENT); end else {$ENDIF JVCLThemesEnabled} begin DrawBackground(BackColor, ACanvas); Frame3D(ACanvas, R, clBtnHighlight, clBlack, 1); end; if Cap <> '' then DrawText(ACanvas, Cap, -1, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE); end; procedure DrawDown(ACanvas: TCanvas); begin {$IFDEF JVCLThemesEnabled} if Themed and StyleServices.Enabled then begin DrawThemedBkgrnd(ACanvas, R); R := DrawThemedButtonFace(Self, ACanvas, R, 0, bsAutoDetect, False, True, False, PtInRect(R, ScreenToClient(Mouse.CursorPos))); SetBkMode(Canvas.Handle, Windows.TRANSPARENT); end else {$ENDIF JVCLThemesEnabled} begin DrawBackground(BackColor, ACanvas); Frame3D(ACanvas, R, clBlack, clBtnHighlight, 1); end; if Cap <> '' then DrawText(ACanvas, Cap, -1, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE); end; begin DH := (Height - 2) div Rows; DW := (Width - 2) div Cols; for Row := 0 to Rows - 1 do begin Y0 := 1 + Row * DH; for Col := 0 to Cols - 1 do begin X0 := 1 + Col * DW; R := Rect(X0, Y0, X0 + DW, Y0 + DH); Index := Row * Cols + Col; if Index < Captions.Count then Cap := Captions[Index] else Cap := ''; if Index < Colors.Count then try BackColor := StringToColor(Colors[Index]); except BackColor := clSilver; end else BackColor := clSilver; FBmp.Width := Width; FBmp.Height := Height; if (csDesigning in ComponentState) then DrawUp(FBmp.Canvas) else if (FPtDown.X = Col) and (FPtDown.Y = Row) then begin if FPushDown or FDowns[Index] then DrawDown(FBmp.Canvas) else DrawUp(FBmp.Canvas) end else if FDowns[Index] then DrawDown(FBmp.Canvas) else DrawUp(FBmp.Canvas); if Col = Cols -1 then begin l := Width - X0; if l <> 0 then begin DrawThemedBkgrnd(FBmp.Canvas, Rect(X0 + DW + 2, 0, R.Left + R.Width + l, Height)); end; end; BitBlt(Canvas, 0, 0, Width, Height, FBmp.Canvas, 0, 0, SRCCOPY); end; end; end; procedure TJvArrayButton.SetCols(const Value: Integer); begin if FCols <> Value then if (Value >= 1) and (Value <= 10) then begin FCols := Value; Invalidate; SizeChanged; end; end; procedure TJvArrayButton.SetEnableds(Index: Integer; const Value: Boolean); begin if FEnableds[Index] <> Value then begin FEnableds[Index] := Value; Invalidate; end; end; procedure TJvArrayButton.SetDowns(Index: Integer; const Value: Boolean); begin if FDowns[Index] <> Value then begin FDowns[Index] := Value; Invalidate; end; end; procedure TJvArrayButton.SetRows(const Value: Integer); begin if FRows <> Value then if (Value >= 1) and (Value <= 10) then begin FRows := Value; Invalidate; SizeChanged; end; end; procedure TJvArrayButton.SizeChanged; var OriginalEnableds: array of Boolean; OriginalDowns: array of Boolean; I: Integer; MinLength: Integer; begin SetLength(OriginalEnableds, Length(FEnableds)); for I := 0 to Length(FEnableds) - 1 do OriginalEnableds[I] := FEnableds[I]; SetLength(FEnableds, Rows * Cols); MinLength := Length(OriginalEnableds); if MinLength > Length(FEnableds) then MinLength := Length(FEnableds); for I := 0 to MinLength - 1 do FEnableds[I] := OriginalEnableds[I]; for I := MinLength to Length(FEnableds) - 1 do FEnableds[I] := True; //----------------------------------------------- SetLength(OriginalDowns, Length(FDowns)); for I := 0 to Length(FDowns) - 1 do OriginalDowns[I] := FDowns[I]; SetLength(FDowns, Rows * Cols); MinLength := Length(OriginalDowns); if MinLength > Length(FDowns) then MinLength := Length(FDowns); for I := 0 to MinLength - 1 do FDowns[I] := OriginalDowns[I]; for I := MinLength to Length(FDowns) - 1 do FDowns[I] := False; end; {$IFDEF JVCLThemesEnabled} procedure TJvArrayButton.SetThemed(Value: Boolean); begin if Value <> FThemed then begin FThemed := Value; if FThemed then IncludeThemeStyle(Self, [csParentBackground]) else ExcludeThemeStyle(Self, [csParentBackground]); Invalidate; end; end; {$ENDIF JVCLThemesEnabled} function TJvArrayButton.GetCaptions: TStrings; begin Result := FCaptions; end; procedure TJvArrayButton.SetCaptions(const Value: TStrings); begin FCaptions.Assign(Value); Invalidate; end; procedure TJvArrayButton.FontChanged; begin inherited FontChanged; Canvas.Font.Assign(Font); Invalidate; end; function TJvArrayButton.GetColors: TStrings; begin Result := FColors; end; function TJvArrayButton.GetEnableds(Index: Integer): Boolean; begin Result := FEnableds[Index]; end; function TJvArrayButton.GetDowns(Index: Integer): Boolean; begin Result := FDowns[Index]; end; procedure TJvArrayButton.SetColors(const Value: TStrings); begin FColors.Assign(Value); Invalidate; end; function TJvArrayButton.CellRect(ACol, ARow: Integer): TRect; var DH, DW, X0, Y0: Integer; begin DH := (Height - 2) div Rows; DW := (Width - 2) div Cols; Y0 := 1 + ARow * DH; X0 := 1 + ACol * DW; // pt1:=clienttoscreen(point(X0,Y0)); // pt2:=clienttoscreen(point(X0+DW,Y0+DH)); // result:=rect(pt1.X,pt1.Y,pt2.X,pt2.Y); Result := Rect(X0, Y0, X0 + DW, Y0 + DH); end; procedure TJvArrayButton.DoShowHint(var HintStr: THintString; var CanShow: Boolean; var HintInfo: THintInfo); var ACol, ARow, X, Y: Integer; Index: Integer; begin if HintInfo.HintControl = Self then begin X := HintInfo.CursorPos.X; Y := HintInfo.CursorPos.Y; MouseToCell(X, Y, ACol, ARow); if (ACol < 0) or (ARow < 0) then Exit; Index := ARow * Cols + ACol; if Index < Hints.Count then HintStr := Hints[Index] else HintStr := Hint; HintInfo.CursorRect := CellRect(ACol, ARow); CanShow := True; end; end; procedure TJvArrayButton.SetHints(const Value: THintStringList); begin FHints.Assign(Value); end; {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); finalization UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} end.