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.
Related
I Have a Windows Media Player ActiveX control. I want it to be aligned to its parent TPanel.
The problem is that no matter what I try the WMP control is always set to its initial size without the possibility to resize it.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, XpMan, ExtCtrls, WMPLib_TLB;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
public
Panel: TPanel;
MP: TWindowsMediaPlayer;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 450;
Height := 260;
Panel := TPanel.Create(Self);
Panel.Parent := Self;
Panel.Align := alClient;
MP := TWindowsMediaPlayer.Create(Self);
// MP.stretchToFit := True;
MP.Parent := Panel;
MP.Align := alClient;
MP.URL := 'https://www.w3schools.com/html/mov_bbb.mp4';
end;
When you open the form the WMP control looks fine:
But when you resize the form, the WMP control wont align to the parent Panel:
This is actually the effect I see when trying to enlarge:
What can I do to make the WMP control behave as expected?
I have tried many stupid things like:
procedure TForm1.FormResize(Sender: TObject);
begin
if not Assigned(MP) then Exit;
MP.Width := Panel.ClientWidth;
MP.Height := Panel.ClientHeight;
Panel.Realign;
end;
But nothing works!
This is a bug in Delphi 7 TOleControl.SetBounds in OleCtrls. it was fixed in newer versions.
procedure TOleControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
LRect: TRect;
begin
if ((AWidth <> Width) and (Width > 0)) or ((AHeight <> Height) and (Height > 0)) then
begin
if (FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) or
((FOleObject.SetExtent(DVASPECT_CONTENT, Point(
MulDiv(AWidth, 2540, Screen.PixelsPerInch),
MulDiv(AHeight, 2540, Screen.PixelsPerInch))) <> S_OK)) then
begin
AWidth := Width;
AHeight := Height;
end;
{ fix start }
if FOleInplaceObject <> nil then
begin
LRect := Rect(Left, Top, AWidth, AHeight);
FOleInplaceObject.SetObjectRects(LRect, LRect);
end;
{ fix end }
end;
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
After applying that to a local copy of OleCtrls everything works fine.
I do not know how to call an interactive panel of tools like TeamViewer has. My question is very objective: How can I create a interactive panel where the panel will hide/show at any moment?
Example:
EDIT:
I found a possible solution (code below). Now I want to insert a "Button" glued on the right side and below Panel. How can I make this?
procedure TForm1.btn1Click(Sender: TObject);
begin
AnimateWindow(Panel1.Handle, 800, AW_SLIDE or AW_VER_NEGATIVE or AW_HIDE);
end;
procedure TForm1.btn2Click(Sender: TObject);
begin
AnimateWindow(Panel1.Handle, 800, AW_SLIDE or AW_VER_POSITIVE or AW_ACTIVATE);
end;
type
TForm1 = class(TForm)
pnl1: TPanel;
btn1: TButton;
procedure btn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btn1Click(Sender: TObject);
begin
if btn1.Caption = 'H' then
begin
btn1.Top := 0;
btn1.Caption := 'S';
AnimateWindow(Pnl1.Handle, 400, AW_SLIDE or AW_VER_NEGATIVE or AW_HIDE);
end
else
begin
btn1.Top:= pnl1.Height;
btn1.Caption := 'H';
AnimateWindow(Pnl1.Handle, 400, AW_SLIDE or AW_VER_POSITIVE or AW_ACTIVATE);
end;
end;
end.
This was my solution:
I'm still using AnimateWindow api.
On Button properties, set right = 0
When Panel is visible, the Button have top := Panel.Height
By last, when Panel is no-visible (hidden), Button have top := 0
Try this:
unit NP;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TMainFrm = class(TForm)
Timer1: TTimer;
Timer2: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
public
end;
var
MainFrm: TMainFrm;
Range: integer;
implementation
{$R *.dfm}
procedure TMainFrm.FormCreate(Sender: TObject);
begin
Width := 255;
Height := Screen.Height;
Left := 0 - Width;
Top := 0;
Range := 0;
Timer1.Enabled := True;
Timer2.Enabled := True;
MainFrm.Show;
end;
procedure TMainFrm.Timer1Timer(Sender: TObject);
var
pos: TPoint;
begin
GetCursorPos(pos);
if (pos.X < 10) and (MainFrm.Left < 0) then
begin
Range := 20;
MainFrm.Show;
end;
if (Range <> 0) then
MainFrm.Left := MainFrm.Left + Range;
if MainFrm.Left < 0 - MainFrm.Width then
begin
Range := 0;
MainFrm.Left := 0 - MainFrm.Width;
MainFrm.Hide;
end;
if (Range = 20) and (MainFrm.Left >= 0) then
begin
Range := 0;
MainFrm.Left := 0;
end;
end;
procedure TMainFrm.Timer2Timer(Sender: TObject);
var
pos: TPoint;
begin
GetCursorPos(pos);
if pos.X > MainFrm.Width then
Range := -20;
end;
end.
Axel
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 have two scenarios. One works, one does not. The first (the one that works) invloves a scrollbox sitting directly on a form that when a button is pushed it executes this code:
procedure TForm1.Button2Click(Sender: TObject);
begin
DrawPanel;
end;
procedure TForm1.DrawPanel;
begin
BuildPanel; //Resides on a seperate unit code pasted below
TestPanel.Height := 40;
TestPanel.Width := 100;
TestPanel.Left := Trunc(ScrollBox1.Width / 2) - Trunc(TestPanel.Width / 2);
TestPanel.Top := Trunc(ScrollBox1.Height / 2) - Trunc(TestPanel.Height / 2);
TestPanel.Visible := True;
TestPanel.Parent := ScrollBox1;
end;
unit Unit3;
interface
uses ExtCtrls;
Var
TestPanel : Tpanel;
Procedure BuildPanel;
implementation
procedure BuildPanel;
begin
TestPanel := TPanel.Create(Nil);
end;
end.
The code is identical except for a small difference in the second scenario. The scrollbox sits on a frame that is added to the Templates palette and then dropped down on the form. The button click calls:
procedure TForm1.Button1Click(Sender: TObject);
begin
TestFrame.DrawPanel;
end;
procedure TTestFrame.DrawPanel;
begin
BuildPanel; //Still points to the unit3 code above
TestPanel.Height := 40;
TestPanel.Width := 100;
TestPanel.Left := Trunc(ScrollBox1.Width / 2) - Trunc(TestPanel.Width / 2);
TestPanel.Top := Trunc(ScrollBox1.Height / 2) - Trunc(TestPanel.Height / 2);
TestPanel.Visible := True;
TestPanel.Parent := ScrollBox1;
end;
However the panel will not display in the scrollbox that sits on the frame, when triggered at runtime. I'm not really sure why, can anybody help out? I hope I was specific enough in my question, let me know if anything is unclear. Thanks in advance.
Here's all the code in order.....Hopefully it make it more clear:
//This is the form
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Unit2, Unit3;
type
TForm1 = class(TForm)
Button1: TButton;
TTestFrame1: TTestFrame;
ScrollBox1: TScrollBox;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
TestFrame: TTestFrame;
Procedure DrawPanel;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
TestFrame.DrawPanel;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
DrawPanel;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
TestFrame.Free;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
TestFrame := TTestFrame.Create(Form1);
end;
procedure TForm1.DrawPanel;
begin
BuildPanel;
TestPanel.Height := 40;
TestPanel.Width := 100;
TestPanel.Left := Trunc(ScrollBox1.Width / 2) - Trunc(TestPanel.Width / 2);
TestPanel.Top := Trunc(ScrollBox1.Height / 2) - Trunc(TestPanel.Height / 2);
TestPanel.Visible := True;
TestPanel.Parent := ScrollBox1;
end;
end.
//This is the frame
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Unit3;
type
TTestFrame = class(TFrame)
ScrollBox1: TScrollBox;
private
{ Private declarations }
public
{ Public declarations }
Procedure DrawPanel;
end;
implementation
{$R *.dfm}
{ TTestFrame }
procedure TTestFrame.DrawPanel;
begin
BuildPanel;
TestPanel.Height := 40;
TestPanel.Width := 100;
TestPanel.Left := Trunc(ScrollBox1.Width / 2) - Trunc(TestPanel.Width / 2);
TestPanel.Top := Trunc(ScrollBox1.Height / 2) - Trunc(TestPanel.Height / 2);
TestPanel.Visible := True;
TestPanel.Parent := ScrollBox1;
end;
end.
//This is the unit that mocks my data structure
//In reality it creates an Array of Tpanel that is part of a class.
unit Unit3;
interface
uses ExtCtrls;
Var
TestPanel : Tpanel;
Procedure BuildPanel;
implementation
procedure BuildPanel;
begin
TestPanel := TPanel.Create(Nil);
end;
end.
You just forgot to assign a parent to your dynamic created TestFrame.
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.