dd4607f1c9
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2483 8e941d3f-bd1b-0410-a28a-d453659cc2b4
274 lines
10 KiB
ObjectPascal
274 lines
10 KiB
ObjectPascal
{*********************************************************}
|
|
{* OVCTCBMP.PAS 4.06 *}
|
|
{*********************************************************}
|
|
|
|
{* ***** BEGIN LICENSE BLOCK ***** *}
|
|
{* Version: MPL 1.1 *}
|
|
{* *}
|
|
{* 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/ *}
|
|
{* *}
|
|
{* Software distributed under the License is distributed on an "AS IS" basis, *}
|
|
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *}
|
|
{* for the specific language governing rights and limitations under the *}
|
|
{* License. *}
|
|
{* *}
|
|
{* The Original Code is TurboPower Orpheus *}
|
|
{* *}
|
|
{* The Initial Developer of the Original Code is TurboPower Software *}
|
|
{* *}
|
|
{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *}
|
|
{* TurboPower Software Inc. All Rights Reserved. *}
|
|
{* *}
|
|
{* Contributor(s): *}
|
|
{* *}
|
|
{* ***** END LICENSE BLOCK ***** *}
|
|
|
|
{$I OVC.INC}
|
|
|
|
{$B-} {Complete Boolean Evaluation}
|
|
{$I+} {Input/Output-Checking}
|
|
{$P+} {Open Parameters}
|
|
{$T-} {Typed @ Operator}
|
|
{.W-} {Windows Stack Frame}
|
|
{$X+} {Extended Syntax}
|
|
|
|
unit ovctcbmp;
|
|
{-Orpheus Table Cell - Bitmap type}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFNDEF LCL} Windows, {$ELSE} LclIntf, MyMisc, {$ENDIF}
|
|
SysUtils, Graphics, Classes, OvcTCmmn, OvcTCell;
|
|
|
|
type
|
|
TOvcTCBaseBitMap = class(TOvcBaseTableCell)
|
|
protected
|
|
{.Z+}
|
|
procedure tcPaint(TableCanvas : TCanvas;
|
|
const CellRect : TRect;
|
|
RowNum : TRowNum;
|
|
ColNum : TColNum;
|
|
const CellAttr : TOvcCellAttributes;
|
|
Data : pointer); override;
|
|
{.Z-}
|
|
public
|
|
function EditHandle : THandle; override;
|
|
procedure EditHide; override;
|
|
procedure EditMove(CellRect : TRect); override;
|
|
procedure SaveEditedData(Data : pointer); override;
|
|
procedure StartEditing(RowNum : TRowNum; ColNum : TColNum;
|
|
CellRect : TRect;
|
|
const CellAttr : TOvcCellAttributes;
|
|
CellStyle: TOvcTblEditorStyle;
|
|
Data : pointer); override;
|
|
procedure StopEditing(SaveValue : boolean;
|
|
Data : pointer); override;
|
|
end;
|
|
|
|
TOvcTCCustomBitMap = class(TOvcTCBaseBitMap)
|
|
protected
|
|
{.Z+}
|
|
procedure tcPaint(TableCanvas : TCanvas;
|
|
const CellRect : TRect;
|
|
RowNum : TRowNum;
|
|
ColNum : TColNum;
|
|
const CellAttr : TOvcCellAttributes;
|
|
Data : pointer); override;
|
|
{.Z-}
|
|
public
|
|
{.Z+}
|
|
procedure ResolveAttributes(RowNum : TRowNum; ColNum : TColNum;
|
|
var CellAttr : TOvcCellAttributes); override;
|
|
{.Z-}
|
|
end;
|
|
|
|
TOvcTCBitMap = class(TOvcTCCustomBitMap)
|
|
published
|
|
{properties inherited from custom ancestor}
|
|
property AcceptActivationClick default False;
|
|
property Access default otxDefault;
|
|
property Adjust default otaDefault;
|
|
property Color;
|
|
property Margin default 4;
|
|
property Table;
|
|
property TableColor default True;
|
|
|
|
property OnOwnerDraw;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
|
|
{===TOvcTCBaseBitMap=================================================}
|
|
procedure TOvcTCBaseBitMap.tcPaint(TableCanvas : TCanvas;
|
|
const CellRect : TRect;
|
|
RowNum : TRowNum;
|
|
ColNum : TColNum;
|
|
const CellAttr : TOvcCellAttributes;
|
|
Data : pointer);
|
|
type
|
|
LH = packed record cX, cY : word; end;
|
|
var
|
|
BMInfo : PCellBitMapInfo absolute Data;
|
|
Wd, Ht : integer;
|
|
DisplayWd : integer;
|
|
DisplayHt : integer;
|
|
CellWidth : integer;
|
|
CellHeight : integer;
|
|
SrcRect, DestRect : TRect;
|
|
TransparentColor : TColor;
|
|
CellAdj : TOvcTblAdjust;
|
|
begin
|
|
{blank out the cell (also sets the brush color)}
|
|
inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, Data);
|
|
{if there's no data, the index to the sub-bitmap is zero or
|
|
the cell is invisible anyway, just exit}
|
|
if (Data = nil) or
|
|
(BMInfo^.Index = -1) or
|
|
(CellAttr.caAccess = otxInvisible) then
|
|
Exit;
|
|
{make a note of the adjustment, and calc the cell width and height}
|
|
CellAdj := CellAttr.caAdjust;
|
|
CellWidth := CellRect.Right - CellRect.Left;
|
|
CellHeight := CellRect.Bottom - CellRect.Top;
|
|
{calculate data about the bitmap, including the source rectangle}
|
|
with BMInfo^ do
|
|
begin
|
|
Wd := BM.Width;
|
|
if (Count <= 1) then
|
|
Index := 0
|
|
else
|
|
begin
|
|
Wd := Wd div Count;
|
|
if (Index >= Count) then
|
|
Index := 0;
|
|
end;
|
|
Ht := BM.Height;
|
|
DisplayWd := MinI(Wd, (CellWidth - 2*Margin));
|
|
DisplayHt := MinI(Ht, (CellHeight - 2*Margin));
|
|
with SrcRect do
|
|
begin
|
|
Left := Index * Wd;
|
|
Right := Left + DisplayWd;
|
|
Top := 0;
|
|
Bottom := Top + DisplayHt;
|
|
end;
|
|
TransparentColor := BM.Canvas.Pixels[SrcRect.Left, Ht-1]
|
|
end;
|
|
{calculate the destination rectangle}
|
|
with DestRect do
|
|
begin
|
|
case CellAdj of
|
|
otaTopLeft, otaCenterLeft, otaBottomLeft :
|
|
Left := Margin;
|
|
otaTopRight, otaCenterRight, otaBottomRight :
|
|
Left := (CellWidth - DisplayWd - Margin);
|
|
else
|
|
Left := (CellWidth - DisplayWd) div 2;
|
|
end;{case}
|
|
inc(Left, CellRect.Left);
|
|
case CellAdj of
|
|
otaTopLeft, otaTopCenter, otaTopRight :
|
|
Top := Margin;
|
|
otaBottomLeft, otaBottomCenter, otaBottomRight :
|
|
Top := (CellHeight - DisplayHt - Margin);
|
|
else
|
|
Top := (CellHeight - DisplayHt) div 2;
|
|
end;{case}
|
|
inc(Top, CellRect.Top);
|
|
Right := Left + DisplayWd;
|
|
Bottom := Top + DisplayHt;
|
|
end;
|
|
{brush copy the bitmap onto the table}
|
|
//{$IFNDEF LCL}
|
|
// TableCanvas.BrushCopy(DestRect, BMInfo^.BM, SrcRect, TransparentColor);
|
|
//{$ELSE}
|
|
BrushCopy(TableCanvas, DestRect, BMInfo^.BM, SrcRect, TransparentColor);
|
|
//{$ENDIF}
|
|
end;
|
|
|
|
function TOvcTCBaseBitMap.EditHandle : THandle;
|
|
begin
|
|
{stub out abstract method so BCB doesn't see this as an abstract class}
|
|
Result := 0;
|
|
end;
|
|
|
|
procedure TOvcTCBaseBitMap.EditHide;
|
|
begin
|
|
{stub out abstract method so BCB doesn't see this as an abstract class}
|
|
end;
|
|
|
|
procedure TOvcTCBaseBitMap.EditMove(CellRect : TRect);
|
|
begin
|
|
{stub out abstract method so BCB doesn't see this as an abstract class}
|
|
end;
|
|
|
|
procedure TOvcTCBaseBitMap.SaveEditedData(Data : pointer);
|
|
begin
|
|
{stub out abstract method so BCB doesn't see this as an abstract class}
|
|
end;
|
|
|
|
procedure TOvcTCBaseBitMap.StartEditing(RowNum : TRowNum; ColNum : TColNum;
|
|
CellRect : TRect;
|
|
const CellAttr : TOvcCellAttributes;
|
|
CellStyle: TOvcTblEditorStyle;
|
|
Data : pointer);
|
|
begin
|
|
{stub out abstract method so BCB doesn't see this as an abstract class}
|
|
end;
|
|
|
|
procedure TOvcTCBaseBitMap.StopEditing(SaveValue : boolean;
|
|
Data : pointer);
|
|
begin
|
|
{stub out abstract method so BCB doesn't see this as an abstract class}
|
|
end;
|
|
|
|
|
|
{====================================================================}
|
|
|
|
{===TOvcTCCustomBitMap===============================================}
|
|
procedure TOvcTCCustomBitMap.tcPaint(TableCanvas : TCanvas;
|
|
const CellRect : TRect;
|
|
RowNum : TRowNum;
|
|
ColNum : TColNum;
|
|
const CellAttr : TOvcCellAttributes;
|
|
Data : pointer);
|
|
var
|
|
BitMap : TBitmap absolute Data;
|
|
BMInfo : TCellBitMapInfo;
|
|
begin
|
|
{if there's no bitmap, just let our ancestor deal with it}
|
|
if (Data = nil) then
|
|
inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, nil)
|
|
{otherwise set up a bitmap info record, and let the ancestor paint it}
|
|
else
|
|
begin
|
|
with BMInfo do
|
|
begin
|
|
BM := BitMap;
|
|
Count := 1;
|
|
ActiveCount := 1;
|
|
Index := 0;
|
|
end;
|
|
inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @BMInfo);
|
|
end;
|
|
end;
|
|
{--------}
|
|
procedure TOvcTCCustomBitMap.ResolveAttributes(RowNum : TRowNum; ColNum : TColNum;
|
|
var CellAttr : TOvcCellAttributes);
|
|
begin
|
|
inherited ResolveAttributes(RowNum, ColNum, CellAttr);
|
|
case CellAttr.caAccess of
|
|
otxDefault, otxNormal : CellAttr.caAccess := otxReadOnly;
|
|
end;{case}
|
|
end;
|
|
{====================================================================}
|
|
|
|
|
|
end.
|