{----------------------------------------------------------------------------- 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$ 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 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; FMouseOverBtn: TPoint; FThemed: Boolean; procedure SetThemed(Value: Boolean); procedure SetMouseOverBtn(Col, Row: Integer); function GetCaptions: TStrings; function GetColors: TStrings; procedure SetColor(const Value: TColor); procedure SetCols(Value: Integer); procedure SetRows(Value: Integer); procedure SetCaptions(const Value: TStrings); procedure SetColors(const Value: TStrings); 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); procedure InvalidateCell(Col, Row: Integer); protected procedure FontChanged; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseLeave(AControl: TControl); override; procedure Paint; override; procedure SizeChanged; dynamic; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function MouseToCell(const X, Y: Integer; var ACol, ARow: Integer): Boolean; function GetCellRect(ACol, ARow: Integer; var R: TRect): Boolean; {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 Color: TColor read FColor write SetColor default clBtnFace; 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; property Themed: Boolean read FThemed write SetThemed default False; 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$'; Revision: '$Revision$'; Date: '$Date$'; LogPath: 'JVCL\run' ); {$ENDIF UNITVERSIONING} implementation uses ExtCtrls, Buttons, JvJCLUtils, JvThemes; constructor TJvArrayButton.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 35; Height := 35; FColor := Color; FPushDown := False; FCols := 1; FRows := 1; ShowHint := True; FCaptions := TStringList.Create; FHints := THintStringList.Create; FColors := TStringList.Create; ControlStyle := ControlStyle + [csOpaque]; // reduce flicker, we paint everthing FMouseOverBtn := Point(-1, -1); FThemed := False; end; destructor TJvArrayButton.Destroy; begin FCaptions.Free; FHints.Free; FColors.Free; SetLength(FEnableds, 0); inherited Destroy; end; function TJvArrayButton.MouseToCell(const X, Y: Integer; var ACol, ARow: Integer): Boolean; var DH, DW: Integer; begin DH := (Height - 2) div Rows; DW := (Width - 2) div Cols; ACol := -1; ARow := -1; Result := False; if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then begin ACol := (X - 1) div DW; ARow := (Y - 1) div DH; if (ACol < 0) or (ARow < 0) or (ACol > Cols) or (ARow > Rows) then begin ACol := -1; ARow := -1; end else Result := True; end; end; function TJvArrayButton.GetCellRect(ACol, ARow: Integer; var R: TRect): Boolean; begin if (ACol >= 0) and (ACol < Cols) and (ARow >= 0) and (ARow < Rows) then begin R := CellRect(ACol, ARow); Result := True; end else Result := False; end; procedure TJvArrayButton.InvalidateCell(Col, Row: Integer); var R: TRect; begin if Visible and (Parent <> nil) and Parent.HandleAllocated then if GetCellRect(Col, Row, R) then InvalidateRect(Parent.Handle, R, False); end; procedure TJvArrayButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Col, Row: Integer; Index: Integer; begin if not (csDesigning in ComponentState) then begin if Button = mbLeft then begin if MouseToCell(X, Y, Col, Row) then begin Index := Row * Cols + Col; if FEnableds[Index] then begin FPushDown := True; FPtDown := Point(Col, Row); InvalidateCell(Col, Row); end; end; end; end; inherited MouseDown(Button, Shift, X, Y); end; procedure TJvArrayButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Col, Row: Integer; Index: Integer; begin if not (csDesigning in ComponentState) then begin if (Button = mbLeft) and FPushDown then begin FPushDown := False; if MouseToCell(X, Y, Col, Row) and (Col = FPtDown.X) and (Row = FPtDown.Y) then begin Index := FPtDown.Y * Cols + FPtDown.X; if FEnableds[Index] then begin if FDown then FDowns[Index] := not FDowns[Index]; InvalidateCell(FPtDown.X, FPtDown.Y); if Assigned(FOnArrayButtonClicked) then OnArrayButtonClicked(FPtDown.X, FPtDown.Y); end; end; end; end; inherited MouseUp(BUtton, Shift, X, Y); end; procedure TJvArrayButton.MouseMove(Shift: TShiftState; X, Y: Integer); var Pt: TPoint; begin if not (csDesigning in ComponentState) then begin MouseToCell(X, Y, Pt.X, Pt.Y); SetMouseOverBtn(Pt.X, Pt.Y); end; inherited MouseMove(Shift, X, Y); end; procedure TJvArrayButton.MouseLeave(AControl: TControl); begin inherited MouseLeave(AControl); if not (csDesigning in ComponentState) then SetMouseOverBtn(-1, -1); end; procedure TJvArrayButton.SetMouseOverBtn(Col, Row: Integer); begin if (Col <> FMouseOverBtn.X) or (Row <> FMouseOverBtn.Y) then begin if (FMouseOverBtn.X <> -1) or (FMouseOverBtn.Y <> -1) then if Themed or (FPushDown and (FMouseOverBtn.X = FPtDown.X) and (FMouseOverBtn.Y = FPtDown.Y)) then InvalidateCell(FMouseOverBtn.X, FMouseOverBtn.Y); FMouseOverBtn := Point(Col, Row); if (FMouseOverBtn.X <> -1) or (FMouseOverBtn.Y <> -1) then if Themed or (FPushDown and (FMouseOverBtn.X = FPtDown.X) and (FMouseOverBtn.Y = FPtDown.Y)) then InvalidateCell(FMouseOverBtn.X, FMouseOverBtn.Y); end; end; procedure TJvArrayButton.Paint; var R: TRect; BackColor: TColor; Cap: string; procedure DrawThemedBkgrnd(ACanvas: TCanvas; ARect: TRect); begin ACanvas.Brush.Color := Color; InflateRect(ARect, 1, 1); SetBkMode(ACanvas.Handle, Windows.TRANSPARENT); ACanvas.FillRect(ARect); end; procedure DrawBackground(ACanvas: TCanvas; AColor: TColor); begin ACanvas.Brush.Color := AColor; DrawThemedBackground(Self, ACanvas, R); end; procedure DrawUp(ACanvas: TCanvas; AMouseOver: Boolean); begin {$IFDEF JVCLThemesEnabled} if Themed and StyleServices.Enabled then begin DrawThemedBkgrnd(ACanvas, R); R := DrawThemedButtonFace(Self, ACanvas, R, 0, bsAutoDetect, False, False, False, AMouseOver); SetBkMode(ACanvas.Handle, Windows.TRANSPARENT); end else {$ENDIF JVCLThemesEnabled} begin DrawBackground(ACanvas, BackColor); 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; AMouseOver: Boolean); begin {$IFDEF JVCLThemesEnabled} if Themed and StyleServices.Enabled then begin DrawThemedBkgrnd(ACanvas, R); R := DrawThemedButtonFace(Self, ACanvas, R, 0, bsAutoDetect, False, True, False, AMouseOver); SetBkMode(ACanvas.Handle, Windows.TRANSPARENT); end else {$ENDIF JVCLThemesEnabled} begin DrawBackground(ACanvas, BackColor); Frame3D(ACanvas, R, clBlack, clBtnHighlight, 1); end; if Cap <> '' then DrawText(ACanvas, Cap, -1, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE); end; var Col, Row: Integer; DH, DW: Integer; X0, Y0: Integer; Index: Integer; l: Integer; OldBmp, Bmp: HBITMAP; BmpDC: HDC; BmpCanvas: TCanvas; begin DH := (Height - 2) div Rows; DW := (Width - 2) div Cols; // WinAPI is much faster than TBitmap that fills the rect and copies the image what we don't need. OldBmp := 0; R := Canvas.ClipRect; Bmp := CreateCompatibleBitmap(Canvas.Handle, Width, Height); BmpDC := CreateCompatibleDC(Canvas.Handle); BmpCanvas := TCanvas.Create; try OldBmp := SelectObject(BmpDC, Bmp); BmpCanvas.Handle := BmpDC; IntersectClipRect(BmpDC, R.Left, R.Top, R.Right, R.Bottom); if FThemed then // Fill the border areas BmpCanvas.Brush.Color := Color; BmpCanvas.FillRect(Rect(0, 0, Width, 1)); BmpCanvas.FillRect(Rect(0, 0, 1, Height)); BmpCanvas.FillRect(Rect(DW * Cols, 1, Width, Height)); BmpCanvas.FillRect(Rect(0, DH * Rows, Width, Height)); // Draw the button cells 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); if RectVisible(BmpDC, R) then begin 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 := FColor; end else BackColor := FColor; BmpCanvas.Font := Font; //PEX MouseOver := (Col = FMouseOverBtn.X) and (Row = FMouseOverBtn.Y); if (csDesigning in ComponentState) then DrawUp(BmpCanvas, MouseOver) else if (FPtDown.X = Col) and (FPtDown.Y = Row) then begin if (FPushDown and MouseOver) or FDowns[Index] then DrawDown(BmpCanvas, MouseOver) else DrawUp(BmpCanvas, MouseOver); end else if FDowns[Index] then DrawDown(BmpCanvas, MouseOver) else DrawUp(BmpCanvas, MouseOver); if Col = Cols -1 then begin l := Width - X0; if l <> 0 then DrawThemedBkgrnd(BmpCanvas, Rect(X0 + DW + 2, 0, R.Right + l, Height)); end; end; end; end; BitBlt(Canvas, 0, 0, Width, Height, BmpCanvas, 0, 0, SRCCOPY); finally BmpCanvas.Handle := 0; BmpCanvas.Free; SelectObject(BmpDC, OldBmp); DeleteDC(BmpDC); DeleteObject(Bmp); end; end; procedure TJvArrayButton.SetColor(const Value: TColor); begin FColor := Value; Invalidate; end; procedure TJvArrayButton.SetCols(Value: Integer); begin if FCols <> Value then begin if Value > 10 then Value := 10; if Value >= 1 then begin FCols := Value; Invalidate; SizeChanged; end; 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(Value: Integer); begin if FRows <> Value then begin if Value > 10 then Value := 10; if Value >= 1 then begin FRows := Value; Invalidate; SizeChanged; end; 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; procedure TJvArrayButton.SetThemed(Value: Boolean); begin if Value <> FThemed then begin FThemed := Value; {$IFDEF JVCLThemesEnabled} // if FThemed then // IncludeThemeStyle(Self, [csParentBackground]) // else // ExcludeThemeStyle(Self, [csParentBackground]); Invalidate; {$ENDIF JVCLThemesEnabled} end; end; 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; 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; if MouseToCell(X, Y, ACol, ARow) then begin Index := ARow * Cols + ACol; if Index < Hints.Count then HintStr := Hints[Index] else HintStr := Hint; HintInfo.CursorRect := CellRect(ACol, ARow); CanShow := True; end; 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.