Delphi GDIPLUS change image position - image

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.

Related

Delphi image motion glitch

well, the problem might not be fixable but its really bothering me. I made a simple program that has three menus and used a timer to move the menu's left and right.
The problem comes when i move the images(menus) to the left of the screen(making the image.left negative. It makes this weird glitch, white blocks that show up out of nowhere. I'm not sure whats causing it, although the images(menus) are very high quality, if that's the cause....what can i do?
NB: amateur in Delphi
this is what i have
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, jpeg;
type
TForm1 = class(TForm)
pnl1: TPanel;
tmr1: TTimer;
btn1: TButton;
pnl2: TPanel;
pnl3: TPanel;
btn2: TButton;
btn3: TButton;
tmr2: TTimer;
tmr3: TTimer;
img1: TImage;
img2: TImage;
img3: TImage;
img4: TImage;
pnlmain: TPanel;
shp1: TShape;
procedure btn1Click(Sender: TObject);
procedure tmr1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btn2Click(Sender: TObject);
procedure tmr2Timer(Sender: TObject);
procedure btn3Click(Sender: TObject);
procedure tmr3Timer(Sender: TObject);
private
{ Private declarations }
iBar : Integer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btn1Click(Sender: TObject);
begin
tmr1.Enabled := True;
btn1.Enabled := False;
btn2.Enabled := true;
btn3.Enabled := true;
end;
procedure TForm1.tmr1Timer(Sender: TObject);
begin
if iBar = 1 then
begin
if pnl2.Left <> 70 then
begin
pnl1.Left := pnl1.Left-72;
pnl2.Left := pnl2.Left-72;
pnl3.Left := pnl3.Left-72;
end
else
begin
pnl1.Left := pnl1.Left-70;
pnl2.Left := pnl2.Left-70;
pnl3.Left := pnl3.Left-70;
iBar := 2;
tmr1.Enabled := False;
end;
end;
if iBar = 3 then
begin
if pnl2.Left <> -70 then
begin
pnl3.Left := pnl3.Left+72;
pnl2.Left := pnl2.Left+72;
pnl1.Left := pnl1.Left+72;
end
else
begin
pnl3.Left := pnl3.Left+70;
pnl2.Left := pnl2.Left+70;
pnl1.Left := pnl1.Left+70;
iBar := 2;
tmr1.Enabled := False;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
iBar := 1;
end;
procedure TForm1.btn2Click(Sender: TObject);
begin
tmr2.Enabled := true;
btn2.Enabled := False;
btn1.Enabled := true;
btn3.Enabled := true;
end;
procedure TForm1.tmr2Timer(Sender: TObject);
begin
if iBar = 3 then
begin
if pnl1.Left <> -140 then
begin
pnl3.Left := pnl3.Left+144;
pnl1.Left := pnl1.Left+144;
pnl2.Left := pnl2.Left+144;
end
else
begin
pnl3.Left := pnl3.Left+140;
pnl1.Left := pnl1.Left+140;
pnl2.Left := pnl2.Left+140;
iBar := 1;
tmr2.Enabled := False;
end;
end;
if iBar = 2 then
begin
if pnl1.Left <> -70 then
begin
pnl2.Left := pnl2.Left+72;
pnl1.Left := pnl1.Left+72;
pnl3.Left := pnl3.Left+72;
end
else
begin
pnl2.Left := pnl2.Left+70;
pnl1.Left := pnl1.Left+70;
pnl3.Left := pnl3.Left+70;
iBar := 1;
tmr2.Enabled := False;
end;
end;
end;
procedure TForm1.btn3Click(Sender: TObject);
begin
tmr3.Enabled := True;
btn3.Enabled := False;
btn2.Enabled := true;
btn1.Enabled := true;
end;
procedure TForm1.tmr3Timer(Sender: TObject);
begin
if iBar = 1 then
begin
if pnl3.Left <> 140 then
begin
pnl1.Left := pnl1.Left-144;
pnl3.Left := pnl3.Left-144;
pnl2.Left := pnl2.Left-144;
end
else
begin
pnl1.Left := pnl1.Left-140;
pnl3.Left := pnl3.Left-140;
pnl2.Left := pnl2.Left-140;
iBar := 3;
tmr3.Enabled := False;
end;
end;
if iBar = 2 then
begin
if pnl3.Left <> 70 then
begin
pnl2.Left := pnl2.Left-72;
pnl3.Left := pnl3.Left-72;
pnl1.Left := pnl1.Left-72;
end
else
begin
pnl2.Left := pnl2.Left-70;
pnl3.Left := pnl3.Left-70;
pnl1.Left := pnl1.Left-70;
iBar := 3;
tmr3.Enabled := False;
end;
end;
end;
end.
You will never achieve smooth animation of any sort when driving the animation from a timer and/or relying on windows controls as your "sprites".
The standard timer component in Delphi uses Windows message based timer events, which means that the processing of these events relies on the message handling of your UI thread, which is also dealing with mouse movements, painting and a whole host of other messages required to keep your UI responsive.
Timer messages take the absolute lowest priority.
Similarly, windows controls are designed to manage interaction with a user. Animation and effects can be used as part of that interaction, but the system is not optimised for physically moving controls around the screen since this is an extremely unusual behaviour for a UI control.
You might remember some of the older Windows "joke" programs with a message box where the "OK" button jumps around the screen whenever you try to click on it ... ? Controls that move around are more often annoying than useful.
Animating in this way can be OK as a proof of concept or prototype to put in front of a user to elicit feedback, but you will always run into "glitches" of the sort you describe.
For your "production" code you should re-think your UI implementation.
If you really need an animated menu then design and implement a control that implements that as a behaviour within a single control.
Manage the animation of the elements in that control (i.e. updating the "model" of the positions of the elements) on a background thread. To render each "frame", incorporate a separate thread specifically to post messages to the control to paint itself as frequently as required to achieve smooth animation, this painting is then the only code that has to operate in concert with all the other UI messages your app is dealing with.
As an efficiency refinement, if you have a number of controls being animated in this way in your form/app, you can usually come up with a scheme that uses a single thread to post the paint messages to all the required controls.

Delphi: ListView (vsReport) single column header caption with custom font color?

In a ListView with vsReport ViewStyle, how can I customize the font color of just any single column header caption? For example (the second column header caption has a red font color):
I would handle the NM_CUSTOMDRAW header notification code and respond to this notification message with the CDRF_NEWFONT return code at the CDDS_ITEMPREPAINT rendering stage. The following code shows how to extend list view controls to have the event for specifying header item font color:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, CommCtrl, StdCtrls;
type
TGetHeaderItemFontColorEvent = procedure(Sender: TCustomListView;
ItemIndex: Integer; var FontColor: TColor) of object;
TListView = class(ComCtrls.TListView)
private
FHeaderHandle: HWND;
FOnGetHeaderItemFontColor: TGetHeaderItemFontColorEvent;
procedure WMNotify(var AMessage: TWMNotify); message WM_NOTIFY;
protected
procedure CreateWnd; override;
published
property OnGetHeaderItemFontColor: TGetHeaderItemFontColorEvent read
FOnGetHeaderItemFontColor write FOnGetHeaderItemFontColor;
end;
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
private
procedure GetHeaderItemFontColor(Sender: TCustomListView;
ItemIndex: Integer; var FontColor: TColor);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TListView }
procedure TListView.CreateWnd;
begin
inherited;
FHeaderHandle := ListView_GetHeader(Handle);
end;
procedure TListView.WMNotify(var AMessage: TWMNotify);
var
FontColor: TColor;
NMCustomDraw: TNMCustomDraw;
begin
if (AMessage.NMHdr.hwndFrom = FHeaderHandle) and
(AMessage.NMHdr.code = NM_CUSTOMDRAW) then
begin
NMCustomDraw := PNMCustomDraw(TMessage(AMessage).LParam)^;
case NMCustomDraw.dwDrawStage of
CDDS_PREPAINT:
AMessage.Result := CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT:
begin
FontColor := Font.Color;
if Assigned(FOnGetHeaderItemFontColor) then
FOnGetHeaderItemFontColor(Self, NMCustomDraw.dwItemSpec, FontColor);
SetTextColor(NMCustomDraw.hdc, ColorToRGB(FontColor));
AMessage.Result := CDRF_NEWFONT;
end;
else
AMessage.Result := CDRF_DODEFAULT;
end;
end
else
inherited;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
ListView1.OnGetHeaderItemFontColor := GetHeaderItemFontColor;
end;
procedure TForm1.GetHeaderItemFontColor(Sender: TCustomListView;
ItemIndex: Integer; var FontColor: TColor);
begin
case ItemIndex of
0: FontColor := clRed;
1: FontColor := clGreen;
2: FontColor := clBlue;
end;
end;
end.
The whole project you can download from here. Here's the result of the above example:
You can get the native header control from the listview and then mark the specific item of your column as owner drawn. You only need to change the text color (if you don't remove the string flag) when the header item requests to be drawn. The drawing message will be sent to the header's parent - the listview, hence you need to handle the message there. See here for owner drawn header controls.
Example code:
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
...
private
FLVHeader: HWND;
FSaveLVWndProc: TWndMethod;
procedure LVWndProc(var Msg: TMessage);
procedure SetHeaderItemStyle(Index: Integer);
end;
..
uses commctrl;
..
procedure TForm1.FormCreate(Sender: TObject);
begin
FLVHeader := ListView_GetHeader(ListView1.Handle);
SetHeaderItemStyle(1);
FSaveLVWndProc := ListView1.WindowProc;
ListView1.WindowProc := LVWndProc;
end;
procedure TForm1.SetHeaderItemStyle(Index: Integer);
var
HeaderItem: THDItem;
begin
HeaderItem.Mask := HDI_FORMAT or HDI_TEXT or HDI_LPARAM;
Header_GetItem(FLVHeader, 1, HeaderItem);
HeaderItem.Mask := HDI_FORMAT;
HeaderItem.fmt := HeaderItem.fmt or HDF_OWNERDRAW;
Header_SetItem(FLVHeader, 1, HeaderItem);
end;
procedure TForm1.LVWndProc(var Msg: TMessage);
begin
FSaveLVWndProc(Msg); // thanks to #Kobik (cause SO if called later then WM_NOTIFY case on some (all other then mine?) machines)
case Msg.Msg of
WM_DRAWITEM:
if (TWmDrawItem(Msg).DrawItemStruct.CtlType = ODT_HEADER) and
(TWmDrawItem(Msg).DrawItemStruct.hwndItem = FLVHeader) and
(TWmDrawItem(Msg).DrawItemStruct.itemID = 1) then
SetTextColor(TWmDrawItem(Msg).DrawItemStruct.hDC, ColorToRGB(clRed));
WM_NOTIFY:
if (TWMNotify(Msg).NMHdr.hwndFrom = FLVHeader) and
(TWMNotify(Msg).NMHdr.code = HDN_ITEMCHANGED) then
// also try 'HDN_ENDTRACK' if it doesn't work as expected
SetHeaderItemStyle(1);
WM_DESTROY: ListView1.WindowProc := FSaveLVWndProc;
end;
end;

How to create a pan from composite image in Delphi

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;

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:

Resources