Related
I'm using Delphi 7. I've written some code to create buttons at runtime (I need lots of the exact same buttons in the exact same locations on every form, which is why I've decided to do that). But I'm having trouble referencing them in procedures (OnClick, to be precise). I want another form to open when a button is clicked.
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, jpeg, ExtCtrls;
procedure buttons(a: TForm);
type
TForm2 = class(TForm)
Image1: TImage;
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2; Button1, Button2, Button3, Button4: TButton;
implementation
uses Unit3, Unit4;
{$R *.dfm}
procedure buttons(a: TForm);
begin
Button1 := TButton.Create(a);
Button1.Name := 'Button1';
Button1.Left := 712;
Button1.Top := 96;
Button1.Width := 81;
Button1.Height := 41;
Button1.Visible := True;
Button1.Parent := a;
Button1.Enabled := False;
Button1.Caption := 'Go forwards';
Button2 := TButton.Create(a);
Button2.Name := 'Button2';
Button2.Left := 800;
Button2.Top := 152;
Button2.Width := 81;
Button2.Height := 41;
Button2.Visible := True;
Button2.Parent := a;
Button2.Enabled := False;
Button2.Caption := 'Go right';
Button3 := TButton.Create(a);
Button3.Name := 'Button3';
Button3.Left := 624;
Button3.Top := 152;
Button3.Width := 81;
Button3.Height := 41;
Button3.Visible := True;
Button3.Parent := a;
Button3.Enabled := False;
Button3.Caption := 'Go left';
Button4 := TButton.Create(a);
Button4.Name := 'Button4';
Button4.Left := 712;
Button4.Top := 208;
Button4.Width := 81;
Button4.Height := 41;
Button4.Visible := True;
Button4.Parent := a;
Button4.Enabled := False;
Button4.Caption := 'Go back';
end;
procedure TForm2.FormShow(Sender: TObject);
begin
buttons(Form2);
Button1.Enabled := True;
Button2.Enabled := True;
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
Form3.Show;
Form2.Hide;
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
Form4.Show;
Form2.Hide;
end;
end.
I've declared the OnClicks in 'type', as well, as I probably should. The program runs, but the created buttons don't work, though are clickable. Ideas?
P.S.: I know I could've written more compact code to create all those buttons, but I didn't have time to think about it, and it is pretty much beside the point. I know it might be hard to read - all you need to know is, I set the same kinds of properties on every button - you need only look at Button1, the others are identical.
P.P.S.: NOT a dup question to this: Delphi - Referencing Components created at Runtime. I couldn't find a solution to my problem in that one.
First of all you should clean up your code a bit. But it's not why your code isn't working. It's because you forgot to assign an OnClick Event to your button:
Have a look at this :
unit Unit19;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm19 = class(TForm)
procedure FormCreate(Sender: TObject);
private
Button1: TButton;
Button2: TButton;
Procedure CreateButtons;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
public
{ Public declarations }
end;
var
Form19: TForm19;
implementation
{$R *.dfm}
procedure TForm19.Button1Click(Sender: TObject);
begin
Caption := 'Button1 Clicked';
end;
procedure TForm19.Button2Click(Sender: TObject);
begin
Caption := 'Button2 Clicked';
end;
procedure TForm19.CreateButtons;
begin
Button1 := TButton.Create(Self);
Button1.Name := 'Button1';
Button1.Left := 712;
Button1.Top := 96;
Button1.Width := 81;
Button1.Height := 41;
Button1.Visible := True;
Button1.Parent := Self;
Button1.Enabled := False;
Button1.OnClick := Button1Click;
Button1.Caption := 'Go forwards';
Button2 := TButton.Create(Self);
Button2.Name := 'Button2';
Button2.Left := 800;
Button2.Top := 152;
Button2.Width := 81;
Button2.Height := 41;
Button2.Visible := True;
Button2.Parent := Self;
Button2.Enabled := False;
Button2.Caption := 'Go right';
Button2.OnClick := Button2Click;
end;
procedure TForm19.FormCreate(Sender: TObject);
begin
CreateButtons;
end;
end.
First the cleanup: I've moved the declaration of your button up to the private part of the form that owns them.
About the owner of the button, the parameter of the constructor; It must be the form. Because when you destroy the form it will also destroy your buttons, and no memory will be leaked.
Then the missing OnClick event that is solved with this line:
Button1.OnClick := Button1Click;
I simply tell the button which procedure to be called when the user click the button.
I hope this answers you question.
In your situation I would use Frames. You can place all buttons on this frame, you can change the behavior by using properties, assign all needed events and put it on your form at design time or at run time
I feel my failure so far lies in search terms as information on this has to be pretty common. Basically I am looking for common solutions and best practices when performing resizes on several components while a form is resized.
I have a form with a component that is based upon TScrollBox. The ScrollBox contains rows which are added dynamically at run time. They are basically a subcomponent. Each one has an image on the left and a memo on the right. The height is set based upon the width and aspect ratio of the image. Upon the resize of the scroll box a loop sets the width of the rows triggering the rows own internal resize. The loop also sets the relative top position if the heights have changed.
Screen shot:
Around 16 rows performs fine. My goal is closer to 32 rows which is very choppy and can peg a core at 100% usage.
I have tried:
Added a check to prevent a new resize starting while the previous has yet to complete. It answered if it occured and it does sometimes.
I tried preventing it resizing more often than every 30 ms which would allow for 30 frame per second drawing. Mixed results.
Changed the rows base component from TPanel to TWinControl. Not sure if there is a performance penalty using the Panel but its an old habit.
With and without double buffering.
I would like to allow row resizing to occur during a resize as a preview to how large the image will be in the row. That eliminates one obvious solution that in some applications is an acceptable loss.
Right now the resize code internally for the row is completely dynamic and based upon the dimensions of each image. Next thing I plan to try is to basically specify the Aspect Ratio, Max Width/Height based on the largest image in the collection. This should reduce the amount of math per row. But it seems like the issues are more the resize event and the loop itself?
Full unit code for the components:
unit rPBSSVIEW;
interface
uses
Classes, Controls, Forms, ExtCtrls, StdCtrls, Graphics, SysUtils, rPBSSROW, Windows, Messages;
type
TPBSSView = class(TScrollBox)
private
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ResizeRows(Sender: TObject);
procedure AddRow(FileName: String);
procedure FillRow(Row: Integer; ImageStream: TMemoryStream);
end;
var
PBSSrow: Array of TPBSSRow;
Resizingn: Boolean;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TScrollBox]);
end;
procedure TPBSSView.AddRow(FileName: String);
begin
SetLength(PBSSrow,(Length(PBSSrow) + 1));
PBSSrow[Length(PBSSrow)-1] := TPBSSRow.create(self);
With PBSSrow[Length(PBSSrow)-1] do
begin
Left := 2;
if (Length(PBSSrow)-1) = 0 then Top := 2 else Top := ((PBSSRow[Length(PBSSRow) - 2].Top + PBSSRow[Length(PBSSRow) - 2].Height) + 2);
Width := (inherited ClientWidth - 4);
Visible := True;
Parent := Self;
PanelLeft.Caption := FileName;
end;
end;
procedure TPBSSView.FillRow(Row: Integer; ImageStream: TMemoryStream);
begin
PBSSRow[Row].LoadImageFromStream(ImageStream);
end;
procedure TPBSSView.ResizeRows(Sender: TObject);
var
I, X: Integer;
begin
if Resizingn then exit
else
begin
Resizingn := True;
HorzScrollBar.Visible := False;
X := (inherited ClientWidth - 4);
if Length(PBSSrow) > 0 then
for I := 0 to Length(PBSSrow) - 1 do
Begin
PBSSRow[I].Width := X; //Set Width
if not (I = 0) then //Move all next ones down.
begin
PBSSRow[I].Top := (PBSSRow[(I - 1)].Top + PBSSRow[(I - 1)].Height) + 2;
end;
Application.ProcessMessages;
End;
HorzScrollBar.Visible := True;
Resizingn := False;
end;
end;
constructor TPBSSView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
OnResize := ResizeRows;
DoubleBuffered := True;
VertScrollBar.Tracking := True;
Resizingn := False;
end;
destructor TPBSSView.Destroy;
begin
inherited;
end;
end.
Row Code:
unit rPBSSROW;
interface
uses
Classes, Controls, Forms, ExtCtrls, StdCtrls, Graphics, pngimage, SysUtils;
type
TPBSSRow = class(TWinControl)
private
FImage: TImage;
FPanel: TPanel;
FMemo: TMemo;
FPanelLeft: TPanel;
FPanelRight: TPanel;
FImageWidth: Integer;
FImageHeight: Integer;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure MyPanelResize(Sender: TObject);
procedure LeftPanelResize(Sender: TObject);
published
procedure LoadImageFromStream(ImageStream: TMemoryStream);
property Image: TImage read FImage;
property Panel: TPanel read FPanel;
property PanelLeft: TPanel read FPanelLeft;
property PanelRight: TPanel read FPanelRight;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TWinControl]);
end;
procedure TPBSSRow.MyPanelResize(Sender: TObject);
begin
if (Width - 466) <= FImageWidth then FPanelLeft.Width := (Width - 466)
else FPanelLeft.Width := FImageWidth;
FPanelRight.Width := (Width - FPanelLeft.Width);
end;
procedure TPBSSRow.LeftPanelResize(Sender: TObject);
var
AspectRatio: Extended;
begin
FPanelRight.Left := (FPanelLeft.Width);
//Enforce Info Minimum Height or set Height
if FImageHeight > 0 then AspectRatio := (FImageHeight/FImageWidth) else
AspectRatio := 0.4;
if (Round(AspectRatio * FPanelLeft.Width)) >= 212 then
begin
Height := (Round(AspectRatio * FPanelLeft.Width));
FPanelLeft.Height := Height;
FPanelRight.Height := Height;
end
else
begin
Height :=212;
FPanelLeft.Height := Height;
FPanelRight.Height := Height;
end;
if Fimage.Height >= FImageHeight then FImage.Stretch := False else Fimage.Stretch := True;
if Fimage.Width >= FImageWidth then FImage.Stretch := False else Fimage.Stretch := True;
end;
procedure TPBSSRow.LoadImageFromStream(ImageStream: TMemoryStream);
var
P: TPNGImage;
n: Integer;
begin
P := TPNGImage.Create;
ImageStream.Position := 0;
P.LoadFromStream(ImageStream);
FImage.Picture.Assign(P);
FImageWidth := P.Width;
FImageHeight := P.Height;
end;
constructor TPBSSRow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
BevelInner := bvNone;
BevelOuter := bvNone;
BevelKind := bkNone;
Color := clWhite;
OnResize := MyPanelResize;
DoubleBuffered := True;
//Left Panel for Image
FPanelLeft := TPanel.Create(Self);
with FPanelLeft do
begin
SetSubComponent(true);
Align := alLeft;
Parent := Self;
//SetBounds(0,0,100,100);
ParentBackground := False;
Color := clBlack;
Font.Color := clLtGray;
Constraints.MinWidth := 300;
BevelInner := bvNone;
BevelOuter := bvNone;
BevelKind := bkNone;
BorderStyle := bsNone;
OnResize := LeftPanelResize;
end;
//Image for left panel
FImage := TImage.Create(Self);
FImage.SetSubComponent(true);
FImage.Align := alClient;
FImage.Parent := FPanelLeft;
FImage.Center := True;
FImage.Stretch := True;
FImage.Proportional := True;
//Right Panel for Info
FPanelRight := TPanel.Create(Self);
with FPanelRight do
begin
SetSubComponent(true);
Parent := Self;
Padding.SetBounds(2,5,5,2);
BevelInner := bvNone;
BevelOuter := bvNone;
BevelKind := bkNone;
BorderStyle := bsNone;
Color := clLtGray;
end;
//Create Memo in Right Panels
FMemo := TMemo.create(self);
with FMemo do
begin
SetSubComponent(true);
Parent := FPanelRight;
Align := alClient;
BevelOuter := bvNone;
BevelInner := bvNone;
BorderStyle := bsNone;
Color := clLtGray;
end;
end;
destructor TPBSSRow.Destroy;
begin
inherited;
end;
end.
A few tips:
TWinControl already ís a container, you do not need another panel inside it to add controls
You do not need an TImage component to view a graphic, that can also with TPaintBox, or as in my example control below, a TCustomControl,
Since all of your other panels are not recognizable (borders and bevels are disabled), loose them altogether and place the TMemo directly on your row control,
SetSubComponent is only for design time usage. You do not need it. Nor the Register procedures for that matter.
Put the global rows array inside your class definition, otherwise multiple TPBSSView controls will use the same array!
TWinControl already tracks all its child controls, so you won't need the array anyway, see my example below,
Make use of the Align property to save you from realigning manually,
If the memo control is just for showing text, then remove it and paint the text yourself.
Try this one for starters:
unit PBSSView;
interface
uses
Windows, Messages, Classes, Controls, SysUtils, Graphics, ExtCtrls, StdCtrls,
Forms, PngImage;
type
TPBSSRow = class(TCustomControl)
private
FGraphic: TPngImage;
FStrings: TStringList;
function ImageHeight: Integer; overload;
function ImageHeight(ControlWidth: Integer): Integer; overload;
function ImageWidth: Integer; overload;
function ImageWidth(ControlWidth: Integer): Integer; overload;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure WMWindowPosChanging(var Message: TWMWindowPosChanging);
message WM_WINDOWPOSCHANGING;
protected
procedure Paint; override;
procedure RequestAlign; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure LoadImageFromStream(Stream: TMemoryStream);
property Strings: TStringList read FStrings;
end;
TPBSSView = class(TScrollBox)
private
function GetRow(Index: Integer): TPBSSRow;
procedure WMEnterSizeMove(var Message: TMessage); message WM_ENTERSIZEMOVE;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure WMExitSizeMove(var Message: TMessage); message WM_EXITSIZEMOVE;
protected
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
procedure AddRow(const FileName: TFileName);
procedure FillRow(Index: Integer; ImageStream: TMemoryStream);
property Rows[Index: Integer]: TPBSSRow read GetRow;
end;
implementation
{ TPBSSRow }
constructor TPBSSRow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 300;
Height := 50;
FStrings := TStringList.Create;
end;
destructor TPBSSRow.Destroy;
begin
FStrings.Free;
FGraphic.Free;
inherited Destroy;
end;
function TPBSSRow.ImageHeight: Integer;
begin
Result := ImageHeight(Width);
end;
function TPBSSRow.ImageHeight(ControlWidth: Integer): Integer;
begin
if (FGraphic <> nil) and not FGraphic.Empty then
Result := Round(ImageWidth(ControlWidth) * FGraphic.Height / FGraphic.Width)
else
Result := Height;
end;
function TPBSSRow.ImageWidth: Integer;
begin
Result := ImageWidth(Width);
end;
function TPBSSRow.ImageWidth(ControlWidth: Integer): Integer;
begin
Result := ControlWidth div 2;
end;
procedure TPBSSRow.LoadImageFromStream(Stream: TMemoryStream);
begin
FGraphic.Free;
FGraphic := TPngImage.Create;
Stream.Position := 0;
FGraphic.LoadFromStream(Stream);
Height := ImageHeight + Padding.Bottom;
end;
procedure TPBSSRow.Paint;
var
R: TRect;
begin
Canvas.StretchDraw(Rect(0, 0, ImageWidth, ImageHeight), FGraphic);
SetRect(R, ImageWidth, 0, Width, ImageHeight);
Canvas.FillRect(R);
Inc(R.Left, 10);
DrawText(Canvas.Handle, FStrings.Text, -1, R, DT_EDITCONTROL or
DT_END_ELLIPSIS or DT_NOFULLWIDTHCHARBREAK or DT_NOPREFIX or DT_WORDBREAK);
Canvas.FillRect(Rect(0, ImageHeight, Width, Height));
end;
procedure TPBSSRow.RequestAlign;
begin
{eat inherited}
end;
procedure TPBSSRow.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TPBSSRow.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
inherited;
if (FGraphic <> nil) and not FGraphic.Empty then
Message.WindowPos.cy := ImageHeight(Message.WindowPos.cx) + Padding.Bottom;
end;
{ TPBSSView }
procedure TPBSSView.AddRow(const FileName: TFileName);
var
Row: TPBSSRow;
begin
Row := TPBSSRow.Create(Self);
Row.Align := alTop;
Row.Padding.Bottom := 2;
Row.Parent := Self;
end;
constructor TPBSSView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
VertScrollBar.Tracking := True;
end;
procedure TPBSSView.FillRow(Index: Integer; ImageStream: TMemoryStream);
begin
Rows[Index].LoadImageFromStream(ImageStream);
end;
function TPBSSView.GetRow(Index: Integer): TPBSSRow;
begin
Result := TPBSSRow(Controls[Index]);
end;
procedure TPBSSView.PaintWindow(DC: HDC);
begin
{eat inherited}
end;
procedure TPBSSView.WMEnterSizeMove(var Message: TMessage);
begin
if not AlignDisabled then
DisableAlign;
inherited;
end;
procedure TPBSSView.WMEraseBkgnd(var Message: TWmEraseBkgnd);
var
DC: HDC;
begin
DC := GetDC(Handle);
try
FillRect(DC, Rect(0, VertScrollBar.Range, Width, Height), Brush.Handle);
finally
ReleaseDC(Handle, DC);
end;
Message.Result := 1;
end;
procedure TPBSSView.WMExitSizeMove(var Message: TMessage);
begin
inherited;
if AlignDisabled then
EnableAlign;
end;
end.
If this still performs badly, then there are multiple other enhancements possible.
Update:
Flickering eliminated by overriding/intercepting WM_ERASEBKGND (and intercepting PaintWindow for versions < XE2),
Better performance by making use of DisableAlign and EnableAlign.
I don't know if this will make a significant difference, but instead setting PBSSRow[I].Width and PBSSRow[I].Top separately, make one call to PBSSRow[I].SetBounds instead. This will save you one Resize event for that SubComponent.
I like to place a feedback button on may main (MDIParent) form that simulates those in webpages.
Like it to grow when the mouse goes over it. Just like the web.
The form with questions and the send of the data, I really don't need it, just the visual stuff.
Is there any such component ?.
I don't think it's difficult to do, but if it already exist it will same me some time.
Thanks
To make an animated slide panel you can use a code like follows:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FFeedbackBtn: TPanel;
FFeedbackPanel: TPanel;
procedure OnFeedbackBtnMouseEnter(Sender: TObject);
procedure OnFeedbackPanelMouseLeave(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FFeedbackBtn := TPanel.Create(Self);
FFeedbackBtn.Parent := Self;
FFeedbackBtn.Anchors := [akLeft, akTop, akBottom];
FFeedbackBtn.Caption := '';
FFeedbackBtn.SetBounds(0, 0, 40, ClientHeight);
FFeedbackBtn.OnMouseEnter := OnFeedbackBtnMouseEnter;
FFeedbackPanel := TPanel.Create(Self);
FFeedbackPanel.Parent := Self;
FFeedbackPanel.Anchors := [akLeft, akTop, akBottom];
FFeedbackPanel.Caption := 'Feedback panel';
FFeedbackPanel.Visible := False;
FFeedbackPanel.SetBounds(0, 0, 250, ClientHeight);
FFeedbackPanel.OnMouseLeave := OnFeedbackPanelMouseLeave;
end;
procedure TForm1.OnFeedbackBtnMouseEnter(Sender: TObject);
begin
AnimateWindow(FFeedbackPanel.Handle, 150, AW_ACTIVATE or AW_SLIDE or
AW_HOR_POSITIVE);
end;
procedure TForm1.OnFeedbackPanelMouseLeave(Sender: TObject);
begin
AnimateWindow(FFeedbackPanel.Handle, 150, AW_HIDE or AW_SLIDE or
AW_HOR_NEGATIVE);
end;
end.
Update:
Here's another version of the above, now with a vertical text like a typical feedback button has, rendered on a paint box stretched on the button panel:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FFeedbackBtn: TPanel;
FFeedbackBtnOverlay: TPaintBox;
FFeedbackPanel: TPanel;
procedure OnFeedbackBtnMouseEnter(Sender: TObject);
procedure OnFeedbackPanelMouseLeave(Sender: TObject);
procedure OnFeedbackBtnOverlayPaint(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FFeedbackBtn := TPanel.Create(Self);
FFeedbackBtn.Parent := Self;
FFeedbackBtn.Anchors := [akLeft, akTop, akBottom];
FFeedbackBtn.Caption := '';
FFeedbackBtn.Color := $0000B3FF;
FFeedbackBtn.ParentBackground := False;
FFeedbackBtn.SetBounds(0, 0, 40, ClientHeight);
FFeedbackBtnOverlay := TPaintBox.Create(Self);
FFeedbackBtnOverlay.Parent := FFeedbackBtn;
FFeedbackBtnOverlay.Align := alClient;
FFeedbackBtnOverlay.OnPaint := OnFeedbackBtnOverlayPaint;
FFeedbackBtnOverlay.OnMouseEnter := OnFeedbackBtnMouseEnter;
FFeedbackPanel := TPanel.Create(Self);
FFeedbackPanel.Parent := Self;
FFeedbackPanel.Anchors := [akLeft, akTop, akBottom];
FFeedbackPanel.Caption := 'Feedback panel';
FFeedbackPanel.Color := $0000F9FF;
FFeedbackPanel.ParentBackground := False;
FFeedbackPanel.Visible := False;
FFeedbackPanel.SetBounds(0, 0, 250, ClientHeight);
FFeedbackPanel.OnMouseLeave := OnFeedbackPanelMouseLeave;
end;
procedure TForm1.OnFeedbackBtnMouseEnter(Sender: TObject);
begin
AnimateWindow(FFeedbackPanel.Handle, 150, AW_ACTIVATE or AW_SLIDE or
AW_HOR_POSITIVE);
end;
procedure TForm1.OnFeedbackPanelMouseLeave(Sender: TObject);
begin
AnimateWindow(FFeedbackPanel.Handle, 150, AW_HIDE or AW_SLIDE or
AW_HOR_NEGATIVE);
end;
procedure TForm1.OnFeedbackBtnOverlayPaint(Sender: TObject);
var
S: string;
X, Y: Integer;
begin
S := 'Feedback...';
with FFeedbackBtnOverlay do
begin
Canvas.Brush.Color := $0000B3FF;
Canvas.FillRect(ClientRect);
Canvas.Font.Orientation := 900;
X := (ClientWidth - Canvas.TextHeight(S)) div 2;
Y := ClientHeight - (ClientHeight - Canvas.TextWidth(S)) div 2;
Canvas.TextOut(X, Y, S);
end;
end;
end.
And the result:
You should also implement some logic to prevent user to hide the feedback panel when will actually filling the fields, but it's a natural weakness of such kind of a feedback form.
I have an object consisting of a TFrame, on it a TPanel and on that a TImage. A bitmap is assigned to the TImage containing a piano roll. This frame-object is put on a TImage, containing an image that contains a grid. See the image for an example.
Question: Is it possible to make the frame partially transparent, so that the background image containing the grid (on the main form) is vaguely visible? Ideally the amount of transparency can be set by the user. The bitmap is 32 bit deep but experimenting with the alpha channel did not help. The panel is not strictly necessary. It is used to quickly have a border around the object. I could draw that on the image.
Update 1 A small code example is added. The main unit draws a background with vertical lines. The second unit contains a TFrame and a TImage upon it that draws a horizontal line. What I would like to see is that the vertical lines partially shine thru the TFrame Image.
Update 2 What I did not specify in my original question: the TFrame is part of a much bigger application and behaves independently. It would help if the transparency issue could be handled by the TFrame itself.
///////////////// Main unit, on mouse click draw lines and plot TFrame
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls,
Unit2;
type
TForm1 = class(TForm)
Image1: TImage;
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var background: TBitmap;
f: TFrame2;
i, c: Int32;
begin
background := TBitmap.Create;
background.Height := Image1.Height;
background.Width := Image1.Width;
background.Canvas.Pen.Color := clBlack;
for i := 0 to 10 do
begin
c := i * background.Width div 10;
background.Canvas.MoveTo (c, 0);
background.Canvas.LineTo (c, background.Height);
end;
Image1.Picture.Assign (background);
Application.ProcessMessages;
f := TFrame2.Create (Self);
f.Parent := Self;
f.Top := 10;
f.Left := 10;
f.plot;
end;
end.
///////////////////Unit containing the TFrame
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TFrame2 = class(TFrame)
Image1: TImage;
procedure plot;
end;
implementation
{$R *.dfm}
procedure TFrame2.plot;
var bitmap: TBitmap;
begin
bitmap := TBitmap.Create;
bitmap.Height := Image1.Height;
bitmap.Width := Image1.Width;
bitmap.PixelFormat := pf32Bit;
bitmap.Canvas.MoveTo (0, bitmap.Height div 2);
bitmap.Canvas.LineTo (bitmap.Width, bitmap.Height div 2);
Image1.Picture.Assign (bitmap);
end;
end.
Update 3 I had hoped for that there would be some message or API call that would result in a solution that the control could make itself partially transparent, like the WMEraseBkGnd message does for complete transparency. In their solutions both Sertac and NGLN both point at simulating transparency with the AlphaBlend function. This function merges two bitmaps and thus requires a knowledge of the background image. Now my TFrame has an extra property: BackGround: TImage that is assigned by the parent control. That gives the desired result (it's sooo professional to see it working :-)
RRUZ points to the Graphics32 library. What I've seen it produces fantastic results, for me the learning curve is too steep.
Thank you all for your help!
Here's another solution that copies the background image to the top image and AlphaBlends the bitmap over it while preserving opacity of black dots:
unit1:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Unit2, ExtCtrls, ComCtrls, StdCtrls;
type
TForm1 = class(TForm)
Clip_View1: TClip_View;
TrackBar1: TTrackBar;
Label1: TLabel;
procedure TrackBar1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
TrackBar1.Min := 0;
TrackBar1.Max := 255;
TrackBar1.Position := 255;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
Label1.Caption := IntToStr(TrackBar1.Position);
Clip_View1.Transparency := TrackBar1.Position;
end;
end.
unit2:
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TClip_View = class(TFrame)
Image1: TImage;
Panel1: TPanel;
Image2: TImage;
protected
procedure SetTransparency(Value: Byte);
private
FTopBmp: TBitmap;
FTransparency: Byte;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Transparency: Byte read FTransparency write SetTransparency;
end;
implementation
{$R *.dfm}
{ TClip_View }
constructor TClip_View.Create(AOwner: TComponent);
begin
inherited;
Image1.Left := 0;
Image1.Top := 0;
Image1.Picture.LoadFromFile(ExtractFilePath(Application.ExeName) + '..\..\back.bmp');
Image1.Picture.Bitmap.PixelFormat := pf32bit;
Image1.Width := Image1.Picture.Bitmap.Width;
Image1.Height := Image1.Picture.Bitmap.Height;
FTopBmp := TBitmap.Create;
FTopBmp.LoadFromFile(ExtractFilePath(Application.ExeName) + '..\..\top.bmp');
FTopBmp.PixelFormat := pf32bit;
Image2.SetBounds(1, 1, FTopBmp.Width, FTopBmp.Height);
Panel1.SetBounds(20, 20, Image2.Width + 2, Image2.Height + 2);
Image2.Picture.Bitmap.SetSize(Image2.Width, Image2.Height);
Image2.Picture.Bitmap.Canvas.Draw(0, 0, FTopBmp);
end;
destructor TClip_View.Destroy;
begin
FTopBmp.Free;
inherited;
end;
procedure TClip_View.SetTransparency(Value: Byte);
var
Bmp: TBitmap;
R: TRect;
X, Y: Integer;
Pixel: PRGBQuad;
BlendFunction: TBlendFunction;
begin
if Value <> FTransparency then begin
FTransparency := Value;
R := Image2.BoundsRect;
OffsetRect(R, Panel1.Left, + Panel1.Top);
Image2.Picture.Bitmap.Canvas.CopyRect(Image2.ClientRect,
Image1.Picture.Bitmap.Canvas, R);
Bmp := TBitmap.Create;
Bmp.SetSize(FTopBmp.Width, FTopBmp.Height);
Bmp.PixelFormat := pf32bit;
Bmp.Assign(FTopBmp);
try
for Y := 0 to Bmp.Height - 1 do begin
Pixel := Bmp.ScanLine[Y];
for X := 0 to Bmp.Width - 1 do begin
if (Pixel.rgbBlue <> 0) and (Pixel.rgbGreen <> 0) and
(Pixel.rgbRed <> 0) then begin
Pixel.rgbBlue := MulDiv(Pixel.rgbBlue, Value, $FF);
Pixel.rgbGreen := MulDiv(Pixel.rgbGreen, Value, $FF);
Pixel.rgbRed := MulDiv(Pixel.rgbRed, Value, $FF);
Pixel.rgbReserved := Value;
end else // don't touch black pixels
Pixel.rgbReserved := $FF;
Inc(Pixel);
end;
end;
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
AlphaBlend(Image2.Picture.Bitmap.Canvas.Handle,
0, 0, Image2.Picture.Bitmap.Width, Image2.Picture.Bitmap.Height,
Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
BlendFunction);
finally
Bmp.Free;
end;
end;
end;
end.
At launch time:
Apply transparency:
Hide the frame and use Frame.PaintTo. For example, as follows:
unit Unit1;
interface
uses
Windows, Classes, Graphics, Controls, Forms, Unit2, JPEG, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage; //Align = alClient, Visible = False
Frame21: TFrame2; //Visible = False
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
private
FBlendFunc: TBlendFunction;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormPaint(Sender: TObject);
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.Width := Frame21.Width;
Bmp.Height := Frame21.Height;
Frame21.PaintTo(Bmp.Canvas, 0, 0);
Canvas.StretchDraw(ClientRect, Image1.Picture.Graphic);
with Frame21 do
Windows.AlphaBlend(Canvas.Handle, Left, Top, Left + Width, Top + Height,
Bmp.Canvas.Handle, 0, 0, Width, Height, FBlendFunc);
finally
Bmp.Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FBlendFunc.BlendOp := AC_SRC_OVER;
FBlendFunc.BlendFlags := 0;
FBlendFunc.SourceConstantAlpha := 255 div 2;
FBlendFunc.AlphaFormat := 0;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
Invalidate;
end;
end.
The frame unit:
unit Unit2;
interface
uses
Windows, Classes, Controls, Forms, JPEG, ExtCtrls;
type
TFrame2 = class(TFrame)
Image1: TImage; //Align = alClient
Panel1: TPanel; //Align = alClient, BevelWidth = 5
end;
implementation
{$R *.dfm}
end.
Result:
Rewrite the above for your specific situation, ideally painting on a TPaintBox getting rid of the image component on the main form. But when the only significant element of the frame is the image, then I would stop using that too, and begin painting everything myself.
I would use a TPaintBox instead. In its OnPaint event, draw your grid first, then alpha-blend your roll image on top. No need to use any TImage, TPanel, or TFrame components at all.
What is the best way to make a delphi application (delphi 2007 for win32 here) go completely full screen, removing the application border and covering windows task bar ?
I am looking for something similar to what IE does when you hit F11.
I wish this to be a run time option for the user not a design time decision by my good self.
As Mentioned in the accepted answer
BorderStyle := bsNone;
was part of the way to do it. Strangely I kept getting a E2010 Incompatible types: 'TFormBorderStyle' and 'TBackGroundSymbol' error when using that line (another type had bsNone defined).
To overcome this I had to use :
BorderStyle := Forms.bsNone;
Well, this has always worked for me. Seems a bit simpler...
procedure TForm52.Button1Click(Sender: TObject);
begin
BorderStyle := bsNone;
WindowState := wsMaximized;
end;
A Google search turned up the following, additional methods:
(though I think I'd try Roddy's method first)
Manually fill the screen (from: About Delphi)
procedure TSomeForm.FormShow(Sender: TObject) ;
var
r : TRect;
begin
Borderstyle := bsNone;
SystemParametersInfo
(SPI_GETWORKAREA, 0, #r,0) ;
SetBounds
(r.Left, r.Top, r.Right-r.Left, r.Bottom-r.Top) ;
end;
Variation on a theme by Roddy
FormStyle := fsStayOnTop;
BorderStyle := bsNone;
Left := 0;
Top := 0;
Width := Screen.Width;
Height := Screen.Height;
The WinAPI way (by Peter Below from TeamB)
private // in form declaration
Procedure WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo);
message WM_GETMINMAXINFO;
Procedure TForm1.WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo);
Begin
inherited;
With msg.MinMaxInfo^.ptMaxTrackSize Do Begin
X := GetDeviceCaps( Canvas.handle, HORZRES ) + (Width - ClientWidth);
Y := GetDeviceCaps( Canvas.handle, VERTRES ) + (Height - ClientHeight
);
End;
End;
procedure TForm1.Button2Click(Sender: TObject);
Const
Rect: TRect = (Left:0; Top:0; Right:0; Bottom:0);
FullScreen: Boolean = False;
begin
FullScreen := not FullScreen;
If FullScreen Then Begin
Rect := BoundsRect;
SetBounds(
Left - ClientOrigin.X,
Top - ClientOrigin.Y,
GetDeviceCaps( Canvas.handle, HORZRES ) + (Width - ClientWidth),
GetDeviceCaps( Canvas.handle, VERTRES ) + (Height - ClientHeight ));
// Label2.caption := IntToStr(GetDeviceCaps( Canvas.handle, VERTRES ));
End
Else
BoundsRect := Rect;
end;
Maximize the form and hide the title bar. The maximize line is done from memory, but I'm pretty sure WindowState is the property you want.
There's also this article, but that seems too complicated to me.
procedure TForm1.FormCreate(Sender: TObject) ;
begin
//maximize the window
WindowState := wsMaximized;
//hide the title bar
SetWindowLong(Handle,GWL_STYLE,GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
ClientHeight := Height;
end;
Edit: Here's a complete example, with "full screen" and "restore" options. I've broken out the different parts into little procedures for maximum clarity, so this could be greatly compressed into just a few lines.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
btnGoFullScreen: TButton;
btnNotFullScreen: TButton;
btnShowTitleBar: TButton;
btnHideTitleBar: TButton;
btnQuit: TButton;
procedure btnGoFullScreenClick(Sender: TObject);
procedure btnShowTitleBarClick(Sender: TObject);
procedure btnHideTitleBarClick(Sender: TObject);
procedure btnNotFullScreenClick(Sender: TObject);
procedure btnQuitClick(Sender: TObject);
private
SavedLeft : integer;
SavedTop : integer;
SavedWidth : integer;
SavedHeight : integer;
SavedWindowState : TWindowState;
procedure FullScreen;
procedure NotFullScreen;
procedure SavePosition;
procedure HideTitleBar;
procedure ShowTitleBar;
procedure RestorePosition;
procedure MaximizeWindow;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btnQuitClick(Sender: TObject);
begin
Application.Terminate;
end;
procedure TForm1.btnGoFullScreenClick(Sender: TObject);
begin
FullScreen;
end;
procedure TForm1.btnNotFullScreenClick(Sender: TObject);
begin
NotFullScreen;
end;
procedure TForm1.btnShowTitleBarClick(Sender: TObject);
begin
ShowTitleBar;
end;
procedure TForm1.btnHideTitleBarClick(Sender: TObject);
begin
HideTitleBar;
end;
procedure TForm1.FullScreen;
begin
SavePosition;
HideTitleBar;
MaximizeWindow;
end;
procedure TForm1.HideTitleBar;
begin
SetWindowLong(Handle,GWL_STYLE,GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
ClientHeight := Height;
end;
procedure TForm1.MaximizeWindow;
begin
WindowState := wsMaximized;
end;
procedure TForm1.NotFullScreen;
begin
RestorePosition;
ShowTitleBar;
end;
procedure TForm1.RestorePosition;
begin
//this proc uses what we saved in "SavePosition"
WindowState := SavedWindowState;
Top := SavedTop;
Left := SavedLeft;
Width := SavedWidth;
Height := SavedHeight;
end;
procedure TForm1.SavePosition;
begin
SavedLeft := Left;
SavedHeight := Height;
SavedTop := Top;
SavedWidth := Width;
SavedWindowState := WindowState;
end;
procedure TForm1.ShowTitleBar;
begin
SetWindowLong(Handle,gwl_Style,GetWindowLong(Handle,gwl_Style) or ws_Caption or ws_border);
Height := Height + GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end.
Put to the form onShow event such code:
WindowState:=wsMaximized;
And to the OnCanResize this:
if (newwidth<width) and (newheight<height) then
Resize:=false;
How to constrain a sub-form within the Mainform like it was an MDI app., but without the headaches! (Note: The replies on this page helped me get this working, so that's why I posted my solution here)
private
{ Private declarations }
StickyAt: Word;
procedure WMWINDOWPOSCHANGING(Var Msg: TWMWINDOWPOSCHANGING); Message M_WINDOWPOSCHANGING;
Procedure WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
later...
procedure TForm2.WMWINDOWPOSCHANGING(var Msg: TWMWINDOWPOSCHANGING);
var
A, B: Integer;
iFrameSize: Integer;
iCaptionHeight: Integer;
iMenuHeight: Integer;
begin
iFrameSize := GetSystemMetrics(SM_CYFIXEDFRAME);
iCaptionHeight := GetSystemMetrics(SM_CYCAPTION);
iMenuHeight := GetSystemMetrics(SM_CYMENU);
// inside the Mainform client area
A := Application.MainForm.Left + iFrameSize;
B := Application.MainForm.Top + iFrameSize + iCaptionHeight + iMenuHeight;
with Msg.WindowPos^ do
begin
if x <= A + StickyAt then
x := A;
if x + cx >= A + Application.MainForm.ClientWidth - StickyAt then
x := (A + Application.MainForm.ClientWidth) - cx + 1;
if y <= B + StickyAt then
y := B;
if y + cy >= B + Application.MainForm.ClientHeight - StickyAt then
y := (B + Application.MainForm.ClientHeight) - cy + 1;
end;
end;
and yet more...
Procedure TForm2.WMGetMinMaxInfo(Var msg: TWMGetMinMaxInfo);
var
iFrameSize: Integer;
iCaptionHeight: Integer;
iMenuHeight: Integer;
Begin
inherited;
iFrameSize := GetSystemMetrics(SM_CYFIXEDFRAME);
iCaptionHeight := GetSystemMetrics(SM_CYCAPTION);
iMenuHeight := GetSystemMetrics(SM_CYMENU);
With msg.MinMaxInfo^.ptMaxPosition Do
begin
// position of top when maximised
X := Application.MainForm.Left + iFrameSize + 1;
Y := Application.MainForm.Top + iFrameSize + iCaptionHeight + iMenuHeight + 1;
end;
With msg.MinMaxInfo^.ptMaxSize Do
Begin
// width and height when maximized
X := Application.MainForm.ClientWidth;
Y := Application.MainForm.ClientHeight;
End;
With msg.MinMaxInfo^.ptMaxTrackSize Do
Begin
// maximum size when maximised
X := Application.MainForm.ClientWidth;
Y := Application.MainForm.ClientHeight;
End;
// to do: minimum size (maybe)
End;
In my case, the only working solution is:
procedure TFormHelper.FullScreenMode;
begin
BorderStyle := bsNone;
ShowWindowAsync(Handle, SW_MAXIMIZE);
end;
You need to make sure Form position is poDefaultPosOnly.
Form1.Position := poDefaultPosOnly;
Form1.FormStyle := fsStayOnTop;
Form1.BorderStyle := bsNone;
Form1.Left := 0;
Form1.Top := 0;
Form1.Width := Screen.Width;
Form1.Height := Screen.Height;
Tested and works on Win7 x64.
Try:
Align = alClient
FormStyle = fsStayOnTop
This always align to the primary monitor;
Hm. Looking at the responses I seem to remember dealing with this about 8 years ago when I coded a game. To make debugging easier, I used the device-context of a normal, Delphi form as the source for a fullscreen display.
The point being, that DirectX is capable of running any device context fullscreen - including the one allocated by your form.
So to give an app "true" fullscreen capabilities, track down a DirectX library for Delphi and it will probably contain what you need out of the box.