around png image appears strange rectangle on Load image or when image is moved.
Rectangle appears rarely in 24bit PNG, or jpg, but with 32bit PNG is problem. Does anyone know what causes it? PNG are created in Photoshop. I tried also gimp but same problem.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, pngimage, jpeg, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
Timer1: TTimer;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Label1: TLabel;
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
png:TPngImage;
rs:TResourceStream;
ms:TMemoryStream;
implementation
{$R *.dfm}
{$R FB.RES}
procedure TForm1.Button1Click(Sender: TObject);
begin
rs:=TResourceStream.Create(hInstance,'24bitpng',RT_RCDATA);
png:=TPngImage.Create;
png.LoadFromStream(rs);
Image1.Picture.Graphic:=png;
rs.Free;
Label1.Caption:=Button1.Caption;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
rs:=TResourceStream.Create(hInstance,'32bitpng',RT_RCDATA);
png:=TPngImage.Create;
png.LoadFromStream(rs);
Image1.Picture.Graphic:=png;
rs.Free;
Label1.Caption:=Button2.Caption;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Form1.Close;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
Timer1.Enabled:=True;
Image2.Left:=0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DoubleBuffered:=True; //This did the job, now no flickering around
Form1.BorderStyle:=bsnone;
Form1.Position:=poScreenCenter;
Label1.Caption:=Button1.Caption;
end;
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Screen.Cursor:=crSizeAll;
ReleaseCapture;
SendMessage(Form1.Handle, WM_SYSCOMMAND, 61458, 0) ;
Screen.Cursor:=crDefault;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if image2.Left<300 then
image2.Left:=image2.Left+2
else
Timer1.Enabled:=False;
end;
end.
This i tried.
...
protected
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
...
begin
procedure TForm1.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
end.
Your basic approach is flawed. You are not expected to use TImage controls to show animations. These controls are designed for displaying static images. As a crude solution you could enable double buffering for the form. Do this by setting DoubleBuffered to True. This has side-effects that may be undesirable. In any case, the entire approach should make you feel queasy.
The right approach is to render the entire image to a drawing surface. In an ideal world you would have a single windowed control that rendered the background in response to WM_ERASEBKGND, and then painted the dynamic content in response to WM_PAINT. This is what I would do.
As a simpler half way house you could use a TPaintBox or perhaps even the form's OnPaint handler. These approaches would have you painting the entire image in response to WM_PAINT. That should be free of flicker. If not then perhaps you'll need to resort to painting to an off-screen bitmap and then blitting that to the paint surface.
Related
I'm getting an error in Pascal, and according to my research it's due to a declaration error (class or variable). It has to be something small, since it was working just fine. I would really appreciate any help.
To be more specific, the error I'm getting is:
'External:ACCESS VIOLATION' with message: Accedd violation reading from address $000004A8. In line 66: Efa.Text:=D.Fa ;
unit UnidadProyectoInformaticaUno;
{$mode objfpc}{$H+}{$R+}{$Q+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,Math;
type
{ TForm1 }
TForm1 = class(TForm)
BNext: TButton;
BPrev: TButton;
BAdd: TButton;
BDel: TButton;
BClose: TButton;
EFa: TEdit;
EIm: TEdit;
EOch: TEdit;
EOt: TEdit;
ENum: TEdit;
LabFa: TLabel;
LabIm: TLabel;
LabOch: TLabel;
LabOt: TLabel;
LabNUM: TLabel;
procedure BAddClick(Sender: TObject);
procedure BCloseClick(Sender: TObject);
procedure BDelClick(Sender: TObject);
procedure BNextClick(Sender: TObject);
procedure BPrevClick(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
type
R= record
Fa,Im,Och: string[20];
Ot:array[1..5] of integer;
end;
Var F:file of R;
D,D1,D2:R;
Irec,i,j,k:integer;
note,grade,nada:string;
procedure OutRec;
begin
with Form1 do
IF Irec > 0 then
begin
seek(F,Irec-1);
read(F,D);
EFa.Text:=D.Fa;
EIm.Text:=D.Im;
for i:= 1 to 5 do
begin
grade:= grade +IntToStr(D.Ot[i])+' ';
end;
Eot.Text:=grade;
EOch.Text:=D.Och;
Enum.Text:= IntToStr(Irec);
end
else
begin
EFa.Text:=nada;
Enum.Text:=nada;
end;
end;
{ TForm1 }
procedure TForm1.BNextClick(Sender: TObject);
begin
If Irec = filesize(F) then
Exit
else
Irec:= Irec+1;
OutRec;
end;
procedure TForm1.BAddClick(Sender: TObject);
begin
D.Fa:=Efa.Text;
D.Im:=Eim.Text;
D.Och:=EOch.Text;
Note:= Eot.text;
for i:= 1 to 5 do
begin
k:=Pos(' ',Note);
D.Ot[i]:= strToInt(Copy(Note,1,k-1));
Delete(Note,1,k);
end;
seek(F,FileSize(F));
Write(F,D);
Irec:= FileSize(F);
OutRec;
end;
procedure TForm1.BCloseClick(Sender: TObject);
begin
close
end;
procedure TForm1.BDelClick(Sender: TObject);
begin
for i:= Irec+1 to Filesize(F) do
begin
seek(F,i-1);
read(F,D);
Seek(F,i-2);
Write(F,D);
end;
Seek(F,Filesize(f)-1);
Truncate(F);
Irec:= Min(Irec,FileSIze(F));
Outrec;
end;
procedure TForm1.BPrevClick(Sender: TObject);
begin
if Irec<2 then Exit;
Irec:= Irec-1;
OutRec;
end;
function Sort(Z:R):string;
begin
Result:=Z.Fa+' '+Z.Im+' '+Z.Och;
end;
procedure BStatus;
begin
with Form1 do
BNext.Enabled:= Irec < FileSize(f);
end;
procedure B1Status;
begin
with Form1 do
BPrev.Enabled:= Irec > 1;
end;
procedure B2Status;
begin
with Form1 do
BAdd.Enabled:= length(Eot.Text) > 0 ;
end;
procedure B3Status;
begin
with Form1 do
BDel.Enabled:= IRec > 0;
end;
begin
assignfile(F,'file.dat');
try reset(F);
except
rewrite(F);
end;
Irec:= Min(1,filesize(F));
OutRec;
for i :=1 to filesize(F)-1 do
for j:= Filesize(F) to i do
begin
seek(F,i);
read(F,D1,D2);
if Sort(D1)>Sort(D2) then
begin
write(f,D2,D1);
end;
end;
end.
In Free Pascal Reference guide, version 3.04 (May 2018), Paragraph 16.2 that deals with Units, it is said that a unit may have an initialization part and a finalization part. It is also said: "An initialization section by itself (i.e. without finalization) may simply be replaced by a statement block.", which is what you have in your code.
That statement block, between the begin and end of the unit, executes at program initialization before the Form1 (declared in the same unit) is created. Therefore you can not refer to anything belonging to the form, like fields, controls, methods, etc. in this statement block, neither directly nor indirectly.
You are calling procedure OutRec, which refers to Efa: TEdit of the form. Since the form is not yet created, you get the error of Access violation.
You must rearrange your code so it doesn't attempt to access any parts of the form from the statement block that replaces a unit initialization part.
I wrote a small testprogram to try out the FormCreate and the FormCloseQuery procedure. The FormCreate works fine, but the FormCloseQuery just doesn't want to execute. Did I overlook something? Pressing the "X" on a form-window or using the close method, both doesn't work!
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
(...)
procedure TForm1.FormCreate(Sender: TObject);
beginn
//gets executed without problems
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
case MessageDlg('Question', mtConfirmation, [mbyes, mbno, mbcancel], 0) of
mrYes:
begin
ShowMessage('yes');
CanClose := true;
end;
mrNo:
begin
ShowMessage('no');
CanClose := true;
end;
else
begin
ShowMessage('cancel');
CanClose := true;
end;
end;
end;
Here's the full code:
The lpr-File:
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
The Unit-File:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
ShowMessage('FormCreate Procedure wurde gestartet');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
case MessageDlg('Question', mtConfirmation, [mbyes, mbno, mbcancel], 0) of
mrYes:
begin
ShowMessage('yes');
CanClose := true;
end;
mrNo:
begin
ShowMessage('no');
CanClose := true;
end;
else
begin
ShowMessage('cancel');
CanClose := true;
end;
end;
end;
end.
The solution is/was to hook up the form's OnCloseQuery event of the form to this procedure. Here's a short description how to do it:
Bring up and select the form (in my case "Form1: TForm1") in the object inspector (see explanation below).
In the object inspector go to the tab "events"
Locate the "OnCloseQuery"-Event and select "FormCloseQuery" if you already declared and written the procedure as it was the case in my example. (If you haven't declared/implemented it double click in the dropdown box or click on the button next to it, the one with the three dots, an an empty "OnCloseQuery"-procedure procedure will be added automatically. The code editor will jump directly to the new procedure.)
To bring up / select the form in the object inspector, open the object inspector (F11). If you are looking at the code editor bring up the form first (F12) and click on it. This should bring it up in the object inspector. Make sure the form (the top element in the list) is selected and none of it's components (like buttons etc.).
Here's another explanation: http://www.delphigroups.info/2/b2/444056.html
Let's say, there are 3 forms in a project (Form1, Form2, Form3). Form1 has a button on it with the OnClick event set to Form2.Show. This code executes perfectly, however if Form2's code tries to call Form3.Show, then the project raises an EXTERNAL: SIGSEGV pointing to Customform.inc
Project project1 raised exception class 'External: SIGSEGV'
In file '.\include\customform.inc' at line 2196:
Visible := True;
This is exactly what's happening to my project. All forms were properly created and declared, and the units are linked perfectly. The compilation goes fine, without any errors or warnings.
So it is impossible to make the third form visible. But I've discovered that every kind of interaction would result in an External: SIGSEGV error pointing to random pieces of code which compile and run just fine. I just can't figure out the origin of the error.
If I try to execute my project without the debugger, I get an Access Violation error. Failing code:
procedure TWarForm.FormCreate(Sender: TObject);
Begin
Form3.Show;
end;
from
unit work;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls, BGRAFlashProgressBar, AuthUnit;
type
{ TWarForm }
TWarForm = class(TForm)
ArcaneDustIMG: TImage;
ProgressBar: TBGRAFlashProgressBar;
ArcaneEDT: TEdit;
GoldEDT: TEdit;
GoldIMG: TImage;
Label1: TLabel;
Wallpaper: TImage;
procedure FormCreate(Sender: TObject);
procedure WallpaperMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure WallpaperMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure WallpaperMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ private declarations }
public
{ public declarations }
end;
var
WarForm: TWarForm;
MouseIsDown: Boolean;
PX, PY: Integer;
implementation
{$R *.lfm}
{ TWarForm }
procedure TWarForm.WallpaperMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then begin
MouseIsDown := True;
PX := X;
PY := Y;
end;
end;
procedure TWarForm.FormCreate(Sender: TObject);
Begin
Form3.Show;
end;
procedure TWarForm.WallpaperMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if MouseIsDown then begin
SetBounds(WarForm.Left + (X - PX), WarForm.Top + (Y - PY), WarForm.Width, WarForm.Height);
end;
end;
procedure TWarForm.WallpaperMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MouseIsDown:=False;
end;
end.
You have to create the forms either manualy or set them to "auto create" in your IDE
To Create them manualy just change your code slightly:
TWarForm = class(TForm)
ArcaneDustIMG: TImage;
ProgressBar: TBGRAFlashProgressBar;
ArcaneEDT: TEdit;
GoldEDT: TEdit;
GoldIMG: TImage;
Label1: TLabel;
Wallpaper: TImage;
Form2: TForm2; // insert Form2
Form3: TForm3; // and Form3
procedure FormCreate(Sender: TObject);
procedure WallpaperMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure WallpaperMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure WallpaperMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ private declarations }
public
{ public declarations }
end;
..
procedure TWarForm.FormCreate(Sender: TObject);
Begin
Form3 := TForm3.Create(Self);
Form3.Show;
end;
If you do so, don't forget to call Form3.Free at the end of your application execution.
I'm kind of new to delphi graphics methods and I'm stucked at creating a ... viewport , thats how I call it while i was doing it for a project. I'm sorry I can't provide any code for it but I'm stuck at the logic part , searching google pointed me to some OnPaint , Draw methods. But those are not what I'm trying to accomplish, since I have , for example:
A 1600x1000 background image anchored to the client's top/bottom/right and left.
Multiple TImage elements placed at set x/y coords.
A "hotspot" like a map element in HTML where I can set the clickable areas (for the images i'm placing at step 2)
No zoom needed.
And the most important thing, while the background is dragged, those TImages placed on top of the background need to be dragged too.
My logic (in HTML/jQuery) was to create a #viewportBinder (which was the div i was dragging, transparent bg), followed by another div inside it called #viewtown (1600x1000, the background) which contains the divs (those TImages) placed at set coordinates in CSS.
So when I am dragging the viewportBinder, jQuery sets the new x/y on the #viewport. Implicitly, the divs (TImages) inside the #viewport are moving because the parent was positioned relative.
Does anybody have any experience with this kind of project ? Any snippet of code ?
To be more specific i'll give you my html example of what i accomplised and what i want to port into Delphi code: http://www.youtube.com/watch?v=9iYqzvZFnGA
Sorry if i'm not clear enough, i have no starting point since I have no experience with this in delphi at all. (using RAD Studio 2010)
A very short example how it could be realized in an easy way.
You would use a Paintbox for painting, 1 Backimage, an array of Records with info and transparent pngimages.
Canvas can be manipulated in offset/zoom/rotation.
Moving and hitdetection would happen in mousedown and mousemove.
It's not complete, but might give you an idea how it could be done.
[delphi]
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls,PNGImage, StdCtrls;
type
TBuilding=Record // record for building informations
Pos:TPoint;
PNGImage:TPngImage;
// what ever needed
End;
TBuildingArray=Array of TBuilding; // array of buildings
TForm1 = class(TForm)
PaintBox1: TPaintBox;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private-Deklarationen }
FXoffs,FYOffs,FZoom:Double; // offset and zoom for painting
FMouseDownPoint:TPoint;
FBackGroundPNG:TPNGImage;
FBuildingArray:TBuildingArray;
procedure Check4Hit(X, Y: Integer);
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
uses Math;
{$R *.dfm}
Procedure SetCanvasZoomAndRotation(ACanvas:TCanvas;Zoom:Double;Angle:Double;CenterpointX,CenterpointY:Double);
var
form : tagXFORM;
Winkel:Double;
begin
Winkel := DegToRad(Angle);
SetGraphicsMode(ACanvas.Handle, GM_ADVANCED);
SetMapMode(ACanvas.Handle,MM_ANISOTROPIC);
form.eM11 := Zoom * cos( Winkel);
form.eM12 := Zoom *Sin( Winkel) ;
form.eM21 := Zoom * (-sin( Winkel));
form.eM22 := Zoom * cos( Winkel) ;
form.eDx := CenterpointX;
form.eDy := CenterpointY;
SetWorldTransform(ACanvas.Handle,form);
end;
Procedure ResetCanvas(ACanvas:TCanvas);
begin
SetCanvasZoomAndRotation(ACanvas , 1, 0, 0,0);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Path:String;
i:Integer;
begin
FZoom := 1;
DoubleBuffered := true;
Path := ExtractFilePath(Paramstr(0));
FBackGroundPNG:=TPNGImage.Create;
FBackGroundPNG.LoadFromFile(Path + 'infect.png');
SetLength(FBuildingArray,3);
for I := 0 to High(FBuildingArray) do
begin
FBuildingArray[i].PNGImage := TPngImage.Create;
FBuildingArray[i].PNGImage.LoadFromFile(Path + Format('B%d.png',[i]));
FBuildingArray[i].Pos.X := I * 300;
FBuildingArray[i].Pos.Y := Random(1000);
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
i:Integer;
begin
for I := 0 to High(FBuildingArray) do
begin
FBuildingArray[i].PNGImage.Free;
end;
FBackGroundPNG.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if FZoom=0.5 then FZoom := 1 else FZoom := 0.5;
PaintBox1.Invalidate;
end;
procedure TForm1.Check4Hit(X,Y:Integer);
var
i,Index:Integer;
R:TRect;
P:TPoint;
begin
index := -1;
for I := 0 to High(FBuildingArray) do
begin
R := Rect(FBuildingArray[i].Pos.X,FBuildingArray[i].Pos.Y
,FBuildingArray[i].Pos.X + FBuildingArray[i].PNGImage.Width
,FBuildingArray[i].Pos.Y + FBuildingArray[i].PNGImage.Height);
P := Point(Round((x - FXOffs)/FZoom) ,Round((y - FYOffs)/FZoom));
if PtInRect(R,P) then Index := i;
end;
if index > -1 then
begin
Caption := Format('Last hit %d',[index]);
end
else Caption := 'No Hit';
end;
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Check4Hit(X,Y);
FMouseDownPoint.X := X;
FMouseDownPoint.Y := Y;
end;
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if ssLeft in Shift then
begin
FXoffs := -( FMouseDownPoint.X - X) ;
FYoffs := -( FMouseDownPoint.Y - Y) ;
if FXoffs>0 then FXoffs := 0;
if FYoffs>0 then FYoffs := 0;
PaintBox1.Invalidate;
end;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
i:Integer;
begin
SetCanvasZoomAndRotation(PaintBox1.Canvas,FZoom,0,FXoffs,FYOffs);
PaintBox1.Canvas.Draw(0,0,FBackGroundPNG);
for I := 0 to High(FBuildingArray) do
begin
PaintBox1.Canvas.Draw(FBuildingArray[i].Pos.X,FBuildingArray[i].Pos.Y,FBuildingArray[i].PNGImage);
end;
end;
end.
[/delphi]
Sorry, but for last several years i working with Lazarus instead of Delphi. But tis article will be informative: http://wiki.lazarus.freepascal.org/Developing_with_Graphics#Create_a_custom_control_which_draws_itself
About relative coordinates nothing to say - it is simple.
About dragging: A long time ago in a galaxy far, far away.. that was something like:
// To start dragging
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
// To stop dragging
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
// To perform dragging
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
Hi does anyone know if it is possible to display a picture as a background to a string grid, Or is anyone aware of any free Grid component that can do this.
Thanks
colin
You could use a TDrawGrid (or a TStringGrid), which supports owner-drawing, and do
procedure TForm1.FormCreate(Sender: TObject);
begin
FBg := TBitmap.Create;
FBg.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\Sample.bmp');
end;
where FBg is a TBitmap (in the form class, for instance), and then do
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
r: TRect;
begin
if not (Sender is TStringGrid) then Exit;
BitBlt(TStringGrid(Sender).Canvas.Handle,
Rect.Left,
Rect.Top,
Rect.Right - Rect.Left,
Rect.Bottom - Rect.Top,
FBg.Canvas.Handle,
Rect.Left,
Rect.Top,
SRCCOPY);
if gdSelected in State then
InvertRect(TStringGrid(Sender).Canvas.Handle, Rect);
r := Rect;
TStringGrid(Sender).Canvas.Brush.Style := bsClear;
DrawText(TStringGrid(Sender).Canvas.Handle,
TStringGrid(Sender).Cells[ACol, ARow],
length(TStringGrid(Sender).Cells[ACol, ARow]),
r,
DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS);
end;
While actually answering here the explicit question of rossmcm in his comment to the code of Andreas Rejbrand, it also complements hís answer to the original question.
Drawing the image beyond the grid boundary, but still within the StringGrid control bounds could be achieved as follows:
type
TStringGrid = class(Grids.TStringGrid)
private
FGraphic: TGraphic;
FStretched: Boolean;
function BackgroundVisible(var ClipRect: TRect): Boolean;
procedure PaintBackground;
protected
procedure Paint; override;
procedure Resize; override;
procedure TopLeftChanged; override;
public
property BackgroundGraphic: TGraphic read FGraphic write FGraphic;
property BackgroundStretched: Boolean read FStretched write FStretched;
end;
TForm1 = class(TForm)
StringGrid: TStringGrid;
Image: TImage;
procedure FormCreate(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TStringGrid }
function TStringGrid.BackgroundVisible(var ClipRect: TRect): Boolean;
var
Info: TGridDrawInfo;
R: TRect;
begin
CalcDrawInfo(Info);
SetRect(ClipRect, 0, 0, Info.Horz.GridBoundary, Info.Vert.GridBoundary);
R := ClientRect;
Result := (ClipRect.Right < R.Right) or (ClipRect.Bottom < R.Bottom);
end;
procedure TStringGrid.Paint;
begin
inherited Paint;
PaintBackground;
end;
procedure TStringGrid.PaintBackground;
var
R: TRect;
begin
if (FGraphic <> nil) and BackgroundVisible(R) then
begin
with R do
ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom);
if FStretched then
Canvas.StretchDraw(ClientRect, FGraphic)
else
Canvas.Draw(0, 0, FGraphic);
end;
end;
procedure TStringGrid.Resize;
begin
inherited Resize;
PaintBackground;
end;
procedure TStringGrid.TopLeftChanged;
begin
inherited TopLeftChanged;
PaintBackground;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
// Usage:
StringGrid.BackgroundGraphic := Image.Picture.Graphic;
StringGrid.BackgroundStretched := True;
end;
If you want to draw the image in the cells as well, then combine both techniques. That they do not follow the same approach, for Andreas uses events where I declare a descendant, should not lead to great difficulty with merging.
Yes, it is possible. TStringGrid inherits from TDrawGrid and does all drawing on its own. You can use the OnDrawCell event to do custom drawing.