How to create a pan from composite image in Delphi - image

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;

Related

TObjectList re-order

I need to re-order a TObjectList, according to some rules. How can I achieve this?
So I add panels to a ScrollBox dinamically.
When I add them, I also add them to the ObjectList in the order that they are added at runtime, for future use. Then I can re-organize the panels in the scrollBox by drag/drop.
I want the ObjectList to mirror the same order that is set at runtime by drag/drop.
Here is my code:
var
MainForm: TMainForm;
PanelList,PanelListTMP:TObjectList;
implementation
...
procedure TMainForm.FormCreate(Sender: TObject);
begin
PanelList:=TObjectList.Create;
PanelListTMP:=TObjectList.Create;
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
AddPanel('0');
AddPanel('1');
AddPanel('2');
AddPanel('3');
AddPanel('4');
end;
procedure TMainForm.Addpanel(what:string);
var
pan:TPanel;
bv:TShape;
begin
pan:=TPanel.Create(self);
pan.Parent:=TheContainer;
pan.Height:=50;
pan.BevelOuter:=bvNone;
pan.BorderStyle:=bsNone;
pan.Ctl3D:=false;
pan.Name:='LayerPan'+what;
pan.Caption:=what;
pan.Align:=alBottom;
pan.OnMouseDown:=panMouseDown;
end;
procedure TMainForm.panMouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
var
i:integer;
idu:String;
panui:TPanel;
begin
panui:=Sender as TPanel;
panui.ParentColor:=false;
panui.BringToFront;
// DRAG DROP STUFF
ReleaseCapture;
panui.Perform(wm_nclbuttondown,HTCAPTION,0);
for i := 0 to MainForm.ComponentCount - 1 do
begin
if MainForm.Components[i] is TWinControl then
if TWinControl(MainForm.Components[i]) is TPanel then
if (TWinControl(MainForm.Components[i]) as TPanel).Parent=MainForm.TheContainer then
begin
(TWinControl(MainForm.Components[i]) as TPanel).Align:=alBottom;
end;
end;
TheContainer.ScrollInView(panui);
ReOrderPanels;
end;
Procedure TMainForm.ReOrderPanels;
begin
end;
What should I do in the ReOrderPanels procedure?
I was thinking about feeding the panels of the ScrollBox from bottom to top into a new TObjectList (PanelListTMP), clear the PanelList and re-add them from the PanelListTMP, but when I do that, I get an error: Access Violation, and EInvalidPointer - Invalid Pointer Operation
So this is what I thought:
procedure TMainForm.ReOrderPanels;
var
ctrl:TControl;
pos:TPoint;
pan:TPanel;
bad:boolean;
ord,i:integer;
begin
memo2.Lines.Add('*** new order START');
panelListTMP.Clear;
// scroll top
TheContainer.VertScrollBar.Position := 0;
// scroll down
TheContainer.VertScrollBar.Position := TheContainer.VertScrollBar.Range;
// get panel
Pos:=TheContainer.ClientOrigin;
Pos.Y:=Pos.Y+TheContainer.Height-5;
ctrl := FindVCLWindow(pos) ;
if ctrl is TPanel then
if TPanel(ctrl).Parent = TheContainer then
begin
pan:=(ctrl as TPanel);
panelListTMP.Add(pan);
end;
ord:=1;
bad:=false;
repeat
repeat
Pos.Y:=pos.Y-1;
until (FindVCLWindow(pos) is TPanel)and(FindVCLWindow(pos)<>pan);
if (FindVCLWindow(pos) is TPanel)and(FindVCLWindow(pos).Name<>'LayerPan') then
begin
pan:=FindVCLWindow(pos) as TPanel;
containeru.VertScrollBar.Position := 0;
containeru.ScrollInView(pan);
ord:=ord+1;
panelListTMP.Add(pan);
end
else
bad:=true;
until bad=true;
// and now I do the swap between the ObjectLists...
panelList.Clear;
for i:=0 to PanelListTMP.Count-1 do
begin
(PanelListTMP.Items[i] as TPanel).Parent:=containeru;
panelList.Add(PanelListTMP.Items[i]);
end;
end;
So I assume that because the ObjectList is storing pointers to the actual objects, then when I clear the initial ObjectList, the actual objects are freed, so the second ObjectList contains a list of pointers that are no longer viable...
But then how can I achieve what I want?
So on ButtonClick, I get a ObjectList that contains panels in the following order:
PanelList[0] - Panel0
PanelList[1] - Panel1
PanelList[2] - Panel2
PanelList[3] - Panel3
PanelList[4] - Panel4
After I drag - drop panels inside the ScrollBox, I can end up with an order like this (in the ScrollBox)
Panel3
panel1
Panel4
Panel2
Panel0
But in the ObjectList, the order is the same as before...
Again, I want to be able to have the ObjectList ordered according to the order of the panels from the scrollBox.
In the re-order procedure I actually get all the panels in the desired order.
I just need to have them in the same order in my ObjectList.
Is there any other way of doing this? Other that with me creating a new class that would hold an index beside a TPanel and use that in the ObjectList to maintain the order?
TObjectList has an OwnsObjects property that is True by default. Make sure to set it to False since you don't want the list to auto-free the objects as they are owned by the Form.
As for the actual sorting of the TObjectList, consider using its Sort() or SortList() method for that. After you have repositioned the Panels as desired within their container, call Sort() or SortList(). The sorting callback you provide will be given two object pointers at a time while the sorting is iterating the list. Use the current positions of the objects relative to each other to tell the list what order they should appear in.
Try something like this:
var
MainForm: TMainForm;
PanelList: TObjectList;
implementation
...
procedure TMainForm.FormCreate(Sender: TObject);
begin
PanelList := TObjectList.Create(False);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
PanelList.Free;
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
AddPanel('0');
AddPanel('1');
AddPanel('2');
AddPanel('3');
AddPanel('4');
end;
procedure TMainForm.Addpanel(what: string);
var
pan: TPanel;
bv: TShape;
begin
pan := TPanel.Create(Self);
try
pan.Parent := TheContainer;
pan.Height := 50;
pan.BevelOuter := bvNone;
pan.BorderStyle := bsNone;
pan.Ctl3D := false;
pan.Name := 'LayerPan'+what;
pan.Caption := what;
pan.Align := alBottom;
pan.OnMouseDown := panMouseDown;
PanelList.Add(pan);
except
pan.Free;
raise;
end;
end;
procedure TMainForm.panMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
i: integer;
idu: String;
panui, pan: TPanel;
tmpList: TObjectList;
begin
panui := Sender as TPanel;
panui.ParentColor := false;
panui.BringToFront;
// DRAG DROP STUFF
ReleaseCapture;
panui.Perform(WM_NCLBUTTONDOWN, HTCAPTION, 0);
tmpList := TObjectList.Create(False);
try
for i := 0 to TheContainer.ControlCount - 1 do
begin
if TheContainer.Controls[i] is TPanel then
tmpList.Add(TPanel(TheContainer.Controls[i]));
end;
for i := 0 to tmpList.Count - 1 do
TPanel(tmpList[i]).Align := alBottom;
finally
tmpList.Free;
end;
TheContainer.ScrollInView(panui);
ReOrderPanels;
end;
function SortPanels(Item1, Item2: Pointer): Integer;
begin
Result := TPanel(Item2).Top - TPanel(Item1).Top;
end;
procedure TMainForm.ReOrderPanels;
begin
PanelList.Sort(SortPanels);
// Alternatively:
{
PanelList.SortList(
function(Item1, Item2: Pointer): Integer;
begin
Result := TPanel(Item2).Top - TPanel(Item1).Top;
end
);
}
end;
I think I found my answer using a temporary ObjectList and Extract(Object)
My code that seems to work is:
procedure TMainForm.ReOrderPanels;
var
ctrl:TControl;
pos:TPoint;
pan,panx:TPanel;
bad:boolean;
ord,i:integer;
begin
panelListTMP.Clear;
panelList.OwnsObjects:=false;
// scroll top
TheContainer.VertScrollBar.Position := 0;
// scroll down
TheContainer.VertScrollBar.Position := TheContainer.VertScrollBar.Range;
// get panel
Pos:=TheContainer.ClientOrigin;
Pos.Y:=Pos.Y+TheContainer.Height-5;
ctrl := FindVCLWindow(pos) ;
if ctrl is TPanel then
if TPanel(ctrl).Parent = TheContainer then
begin
pan:=(ctrl as TPanel);
panelListTMP.Add(PanelList.Extract(pan) as TPanel);
end;
ord:=1;
bad:=false;
repeat
repeat
Pos.Y:=pos.Y-1;
until (FindVCLWindow(pos) is TPanel)and(FindVCLWindow(pos)<>pan);
if (FindVCLWindow(pos) is TPanel)and(FindVCLWindow(pos).Name<>'LayerPan') then
begin
pan:=FindVCLWindow(pos) as TPanel;
TheContainer.VertScrollBar.Position := 0;
TheContainer.ScrollInView(pan);
ord:=ord+1;
panelListTMP.Add(PanelList.Extract(pan) as TPanel);
end
else
bad:=true;
until bad=true;
panelList.Clear;
panelListTMP.OwnsObjects:=false;
i:=0;
while (PanelListTMP.Count<>0) do
panelList.Add(PanelListTMP.Extract(PanelListTMP.Items[i]) as TPanel);
panelList.OwnsObjects:=true;
panelListTmp.Clear;
end;

Delphi GDIPLUS change image position

i am trying to achieve a simple task but by using GDI+ and i cannot find any example.
In my code i need to change an image position (top if to be more specific), but i have no idea if i can do it in a better way.
This is how i do it now:
procedure TForm2.Timer1Timer(Sender: TObject);
var
I: Integer;
begin
if image1.Top = -93 then
Begin
for I := -93 to -1 do
Begin
Sleep(10);
image1.Top := Image1.Top + 1;
Application.ProcessMessages;
End;
End else if image1.Top = 0 then
Begin
for I := 0 downto -92 do
Begin
Sleep(10);
image1.Top := Image1.Top - 1;
Application.ProcessMessages;
End;
End;
end;
Well it's pretty simple, but it does not go smooth, but jumps and redraws itself at each step.
I appreciate your help.
UPDATE:
Thanks to TLama and his inspiration i have found this GDIPlus implementation for delphi 2007
Moving control is a wrong way to animate anything, GDI+ independent. Instead, you should remember the position you want to change for the animation, modify it in the OnTimer event and tell the system that you want to invalidate the target control. Then in the control's OnPaint event you should render whatever you want by that position.
So as the first, replace your TImage component by a TPaintBox since the TImage is used mainly for static images, not for a dynamic rendering. Also use two timers. One for upward animation and one for downward animation.
The following code doesn't take into account approximation of a timer, and it uses less known Delphi 2009 GDI+ Library wrapper for Delphi:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, GdiPlus;
type
TForm1 = class(TForm)
Timer1: TTimer;
Timer2: TTimer;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
GPImage: IGPImage;
FImageTop: Integer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FImageTop := 0;
Timer1.Interval := 15;
Timer2.Interval := 15;
DoubleBuffered := True;
Timer1.Enabled := True;
Timer2.Enabled := False;
GPImage := TGPImage.Create('d:\Image.jpg');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
// no need for the following line since it's a reference of the interface
// GPImage := nil;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if (FImageTop > -93) then
begin
FImageTop := FImageTop - 1;
PaintBox1.Invalidate;
end
else
begin
Timer1.Enabled := False;
Timer2.Enabled := True;
end;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
if (FImageTop < 0) then
begin
FImageTop := FImageTop + 1;
PaintBox1.Invalidate;
end
else
begin
Timer2.Enabled := False;
Timer1.Enabled := True;
end;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
GPGraphics: IGPGraphics;
begin
GPGraphics := TGPGraphics.Create(PaintBox1.Canvas.Handle);
GPGraphics.DrawImage(GPImage, 0, FImageTop);
end;
end.

how can i free a Tpanel That have a TbitBtn that calls to free the Tpanel

I create a Custom Tpanel and inside I put various Custom Components ...
procedure Panel_Comp(Location: TWinControl; NumOfComp: Integer;Left,Top,Height,width:Integer);
begin
MyPanel := TsPanel.Create(Conf);
MyPanel.Name := 'MyPanel' + IntToStr(NumOfComp);
MyPanel.Parent := Location;
MyPanel.Left := Left;
MyPanel.Top := Top;
MyPanel.Height := Height;
MyPanel.Width := width;
MyPanel.Caption := '';
end;
and i call it like this
Panel_Comp(Conf.ScrollBox1,1,8,10,70,322);
in the same logic i put inside the new panel other custom components including a tBitbtn the have a onclick event..
procedure BitBtn_Comp(Location: TWinControl; NumOfComp: Integer; Left,Top,Height,Width,ImageNum: Integer);
begin
MyBitBtn := TBitBtn.Create(Conf);
......
MyBitBtn.tag := NumOfComp;
MyBitBtn.OnClick:= Conf.CloseCurrentPanel;
end;
In the main Forn The TConf.CloseCurrentPanel;
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
TPanel(panelComp).Free;
Application.ProcessMessages;
end;
When I call that I get access violation...
I think is something that I must free all the components inside the panel before free the panel but how I free the BitBtn before the panel and continue the action of the click event?
Here is the FindComponetEx function instead you need it...
function FindComponentEx(const Name: string): TComponent;
var
FormName: string;
CompName: string;
P: Integer;
Found: Boolean;
Form: TForm;
I: Integer;
begin
// Split up in a valid form and a valid component name
P := Pos('.', Name);
if P = 0 then
begin
raise Exception.Create('No valid form name given');
end;
FormName := Copy(Name, 1, P - 1);
CompName := Copy(Name, P + 1, High(Integer));
Found := False;
// find the form
for I := 0 to Screen.FormCount - 1 do
begin
Form := Screen.Forms[I];
// case insensitive comparing
if AnsiSameText(Form.Name, FormName) then
begin
Found := True;
Break;
end;
end;
if Found then
begin
for I := 0 to Form.ComponentCount - 1 do
begin
Result := Form.Components[I];
if AnsiSameText(Result.Name, CompName) then Exit;
end;
end;
Result := nil;
end;
The AV occurs because you are destroying a component (MyBitBtn) while it is still handling Windows messages. The solution is to postpone the destruction until later via PostMessage, similar to this:
unit Unit1;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
StdCtrls;
const
UM_DESTROYPANEL = WM_APP + 623; // some "unique" number; UM = user message
type
TConf = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
strict private
procedure UMDestroyPanel(var Message: TMessage); message UM_DESTROYPANEL;
public
{ Public-Deklarationen }
end;
var
Conf: TConf;
implementation
{$R *.dfm}
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, 0, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
Panel1.Free;
end;
end.
If needed you can use wParam and lParam to pass through parameters like so:
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(Panel1), 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
TObject(Message.WParam).Free;
end;
EDIT:
In your situation I'd probably rewrite TConf.CloseCurrentPanel like this:
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).Tag);
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(panelComp), 0);
end;
Alternatively you can pass through the Tag (might be the better solution because there's less casting involved):
procedure TConf.CloseCurrentPanel(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, TBitBtn(Sender).Tag, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(Message.WParam));
panelComp.Free;
end;
AFAICT the Application.ProcessMessages isn't needed.
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
//Where you need to determine 'PanelComp' if there are.
if Assigned(panelComp) and (PanelComp is TPanel) then
TPanel(panelComp).Free;
Application.ProcessMessages;
end;

How can you change the text orientation in cells in the fixed rows in a Delphi TStringGrid

I have a standard TStringGrid on a form.
I have one Fixed Row in the grid that contains a number of columns, which are all TGridColumns objects. I have set the column titles using the object inspector and the default orientation is horizontal. Is there any way you can make the orientation vertical (like you can in cells in Excel)?
Here's how to render the first row's text vertically in Lazarus:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Grids,
StdCtrls;
type
TStringGrid = class(Grids.TStringGrid)
protected
procedure DrawCellText(ACol, ARow: Integer; ARect: TRect;
AState: TGridDrawState; AText: String); override;
end;
type
TForm1 = class(TForm)
Button1: TButton;
StringGrid1: TStringGrid;
procedure Button1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
procedure TStringGrid.DrawCellText(ACol, ARow: Integer; ARect: TRect;
AState: TGridDrawState; AText: String);
var
TextPosition: TPoint;
begin
if ARow = 0 then
begin
Canvas.Font.Orientation := 900;
TextPosition.X := ARect.Left +
((ARect.Right - ARect.Left - Canvas.TextHeight(AText)) div 2);
TextPosition.Y := ARect.Bottom -
((ARect.Bottom - ARect.Top - Canvas.TextWidth(AText)) div 2);
Canvas.TextOut(TextPosition.X, TextPosition.Y, AText);
end
else
inherited DrawCellText(ACol, ARow, ARect, AState, AText);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
I: Integer;
GridColumn: TGridColumn;
begin
for I := 0 to 4 do
begin
GridColumn := StringGrid1.Columns.Add;
GridColumn.Width := 24;
GridColumn.Title.Font.Orientation := 900;
GridColumn.Title.Layout := tlBottom;
GridColumn.Title.Caption := 'Column no. ' + IntToStr(I);
end;
StringGrid1.RowHeights[0] := 80;
end;
end.
Here's how to render the first row's text of the TStringGrid vertically in Delphi:
I would prefer to use the overriden DrawCell procedure because it seems to me as the easiest way to go because if you want to render the text simply in the OnDrawCell event then you should consider:
if you'll have the DefaultDrawing set to True then the text will already be rendered when the OnDrawCell event is fired, so here I would recommend e.g. to store the cell captions in a separate variable, not into Cells property so then no text will be rendered and you can draw your own stored captions vertically
if you'll have the DefaultDrawing set to False then you'll have to draw the whole cell by your own, including the 3D border, what is IMHO not so cool, and I would personally prefer to let the control draw the background for us
Here is the Delphi code which uses the overriden DrawCell procedure. The text is being centered inside of the cell rectangle; please note that I haven't used the DrawTextEx for text size measurement because this function doesn't take the changed font orientation into account.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids;
type
TStringGrid = class(Grids.TStringGrid)
protected
procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState); override;
end;
type
TForm1 = class(TForm)
Button1: TButton;
StringGrid1: TStringGrid;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TStringGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState);
var
LogFont: TLogFont;
TextPosition: TPoint;
NewFontHandle: HFONT;
OldFontHandle: HFONT;
begin
if ARow = 0 then
begin
GetObject(Canvas.Font.Handle, SizeOf(LogFont), #LogFont);
LogFont.lfEscapement := 900;
LogFont.lfOrientation := LogFont.lfEscapement;
NewFontHandle := CreateFontIndirect(LogFont);
OldFontHandle := SelectObject(Canvas.Handle, NewFontHandle);
TextPosition.X := ARect.Left +
((ARect.Right - ARect.Left - Canvas.TextHeight(Cells[ACol, ARow])) div 2);
TextPosition.Y := ARect.Bottom -
((ARect.Bottom - ARect.Top - Canvas.TextWidth(Cells[ACol, ARow])) div 2);
Canvas.TextRect(ARect, TextPosition.X, TextPosition.Y, Cells[ACol, ARow]);
NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle);
DeleteObject(NewFontHandle);
end
else
inherited DrawCell(ACol, ARow, ARect, AState);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
I: Integer;
begin
for I := 0 to StringGrid1.ColCount - 1 do
begin
StringGrid1.ColWidths[I] := 24;
StringGrid1.Cells[I, 0] := 'Column no. ' + IntToStr(I);
end;
StringGrid1.RowHeights[0] := 80;
end;
end.
And here's how it looks like:

Delphi StringGrid with picture in background

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.

Resources