how can i have a image for Editbox background ?
This is very possible, indeed. In your form, define
private
{ Private declarations }
FBitmap: TBitmap;
FBrush: HBRUSH;
protected
procedure WndProc(var Message: TMessage); override;
and do
procedure TForm1.FormCreate(Sender: TObject);
begin
FBitmap := TBitmap.Create;
FBitmap.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\AS20Utv.bmp');
FBrush := 0;
FBrush := CreatePatternBrush(FBitmap.Handle);
end;
and
procedure TForm1.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_CTLCOLOREDIT, WM_CTLCOLORSTATIC:
if (Message.LParam = Edit1.Handle) and (FBrush <> 0) then
begin
SetBkMode(Message.WParam, TRANSPARENT);
Message.Result := FBrush;
end;
end;
end;
Of course you can wrap this into a component of your own, say TEditEx. If I get time over, I might do this. (And, notice that there is no need to buy an expensive (and maybe not that high-quality) component pack from a third-party company.)
Related
I have a simple form that only contains a TTouchKeyboard. The forms BorderStyle is set to bsToolWindow. To avoid the form getting focus when clicking the touch keyboard I handle the WM_MOUSEACTIVATE message with this implementation:
procedure TKeyboardForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
The BorderStyle setting allows the form to be dragged with the title bar, but in that case the form still gets the focus. Is there a way to avoid this?
Update: I tried adding WS_EX_NOACTIVATE to ExStyle in CreateParams, but unfortunately that doesn't hinder the form to receive focus when dragged.
procedure TKeyboardForm.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.ExStyle := Params.ExStyle or WS_EX_NOACTIVATE;
end;
Because I was not very pleased with the approach that requires me to manually update the focused form variable in the keyboard form, I searched for a more transparent solution and came up with this approach.
Update: The previous approach had some issues with VCL styles. In addition not all of the message handlers were really necessary, though others turned out to be helpful, too. This version works well with VCL styles avoiding any flicker as far as possible:
type
TKeyboardForm = class(TForm)
TouchKeyboard1: TTouchKeyboard;
private
FLastFocusedForm: TCustomForm;
procedure SetLastFocusedForm(const Value: TCustomForm);
protected
procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
property LastFocusedForm: TCustomForm read FLastFocusedForm write SetLastFocusedForm;
public
class constructor Create;
destructor Destroy; override;
function SetFocusedControl(Control: TWinControl): Boolean; override;
end;
type
TKeyboardFormStyleHook = class(TFormStyleHook)
protected
procedure WMNCActivate(var Message: TWMNCActivate); message WM_NCACTIVATE;
end;
procedure TKeyboardFormStyleHook.WMNCActivate(var Message: TWMNCActivate);
begin
{ avoids the title bar being drawn active for blink }
Message.Active := False;
inherited;
end;
class constructor TKeyboardForm.Create;
begin
TCustomStyleEngine.RegisterStyleHook(TKeyboardForm, TKeyboardFormStyleHook);
end;
destructor TKeyboardForm.Destroy;
begin
LastFocusedForm := nil;
inherited;
end;
procedure TKeyboardForm.Notification(AComponent: TComponent; Operation: TOperation);
begin
if (Operation = opRemove) and (AComponent = FLastFocusedForm) then begin
FLastFocusedForm := nil;
end;
inherited;
end;
function TKeyboardForm.SetFocusedControl(Control: TWinControl): Boolean;
begin
LastFocusedForm := Screen.FocusedForm;
result := inherited;
end;
procedure TKeyboardForm.SetLastFocusedForm(const Value: TCustomForm);
begin
if FLastFocusedForm <> Value then
begin
if FLastFocusedForm <> nil then begin
FLastFocusedForm.RemoveFreeNotification(Self);
end;
FLastFocusedForm := Value;
if FLastFocusedForm <> nil then begin
FLastFocusedForm.FreeNotification(Self);
end;
end;
end;
procedure TKeyboardForm.WMActivate(var Message: TWMActivate);
begin
Message.Active := WA_INACTIVE;
inherited;
end;
procedure TKeyboardForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
inherited;
Message.Result := MA_NOACTIVATE;
end;
procedure TKeyboardForm.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
if (FLastFocusedForm <> nil) and (message.FocusedWnd <> FLastFocusedForm.Handle) then begin
SendMessage(FLastFocusedForm.Handle, WM_SETFOCUS, 0, 0);
Message.FocusedWnd := FLastFocusedForm.Handle;
end;
end;
The following combination of WMMouseActivate(), WMNCActivate() and reseting focus seems to fulfill your wishes:
The keyboard form (with BorderStyle = bsToolWindow) has message handlers for WM_MOUSEACTIVATE (as you already have) and WM_NCACTIVATE. The latter for having a point where to reset focus to the window with the edit control.
In addition the keyboardform will keep track of which form holds the edit (or other) control that has focus, and does that by introducing a new method for showing, which I called ShowUnfocused() and a field called FocusedForm: THandle.
procedure TKbdForm.ShowUnfocused(FocusedWindow: THandle);
begin
FocusedForm := FocusedWindow;
Show;
end;
procedure TKbdForm.FormShow(Sender: TObject);
begin
SetForegroundWindow(FocusedForm);
end;
procedure TKbdForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
procedure TKbdForm.WMNCActivate(var Message: TWMNCActivate);
begin
Message.Result := 1; // important
SetForegroundWindow(FocusedForm);
end;
The keyboardform is invoked by the following common code of the edit controls:
procedure TForm17.EditClick(Sender: TObject);
begin
KbdForm.ShowUnfocused(self.Handle);
(Sender as TWinControl).SetFocus;
end;
An alternative to what is said above, could be to set the BorderStyle = bsNone and arrange the dragging of the form with the Mouse Down, Move, Up events directly from the forms surface (or maybe a panel to mimic a top frame), and adding a close button. The challenge would be to get it visually acceptable.
I am trying to color the background of a TComboBox with VCL styles enabled like the way its described in this article but its not working.
http://theroadtodelphi.wordpress.com/2012/02/06/changing-the-color-of-edit-controls-with-vcl-styles-enabled/
Depending of your Delphi version you must
Delphi XE2
For Delphi XE2 you must write a Style Hook
uses
Vcl.Styles,
Vcl.Themes;
type
TComboBoxStyleHookExt= class(TComboBoxStyleHook)
procedure UpdateColors;
strict protected
procedure WndProc(var Message: TMessage); override;
public
constructor Create(AControl: TWinControl); override;
end;
TWinControlClass= class(TWinControl);
{ TComboBoxStyleHookExt }
constructor TComboBoxStyleHookExt.Create(AControl: TWinControl);
begin
inherited;
UpdateColors;
end;
procedure TComboBoxStyleHookExt.UpdateColors;
const
ColorStates: array[Boolean] of TStyleColor = (scComboBoxDisabled, scComboBox);
FontColorStates: array[Boolean] of TStyleFont = (sfComboBoxItemDisabled, sfComboBoxItemNormal);
var
LStyle: TCustomStyleServices;
begin
if Control.Enabled then }//use the control colors
begin
Brush.Color := TWinControlClass(Control).Color;
FontColor := TWinControlClass(Control).Font.Color;
end
else
begin //if not enabled. use the current style colors
LStyle := StyleServices;
Brush.Color := LStyle.GetStyleColor(ColorStates[Control.Enabled]);
FontColor := LStyle.GetStyleFontColor(FontColorStates[Control.Enabled]);
end;
end;
procedure TComboBoxStyleHookExt.WndProc(var Message: TMessage);
begin
case Message.Msg of
WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC,
CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
begin
UpdateColors;
SetTextColor(Message.WParam, ColorToRGB(FontColor));
SetBkColor(Message.WParam, ColorToRGB(Brush.Color));
Message.Result := LRESULT(Brush.Handle);
Handled := True;
end;
CM_ENABLEDCHANGED:
begin
UpdateColors;
Handled := False;
end
else
inherited WndProc(Message);
end;
end;
initialization
TStyleManager.Engine.RegisterStyleHook(TComboBox, TComboBoxStyleHookExt);
Delphi XE3/XE4
Simply remove the seClient value from the StyleElements propertty
ComboBox1.StyleElements:=[seFont, seBorder];
ComboBox2.StyleElements:=[seFont, seBorder];
ComboBox3.StyleElements:=[seFont, seBorder];
I have Delphi 7 and now installed Delphi XE2.
I'm not really experienced with Design, VCL etc. but I would like to have a button (with Caption!) and a simple background image (PNG). I have 3 pictures of custom buttons (1 for click, 1 for mouseoff and 1 for mouseover). I have tried almost everything but I can't seem to find a way to have a simple button with caption in the middle and the images in the background. Please help.
PS.: The button should NOT visually go down on click (this is already in the png image.)
You might adapt this tiny component, no need to install for testing
Test
procedure TForm1.MyOnClick( Sender: TObject );
begin
ShowMessage( 'Hallo' );
end;
procedure TForm1.Button1Click( Sender: TObject );
begin
with TImageButton.Create( self ) do
begin
Parent := self;
Images := Imagelist1;
Index := 0;
HoverIndex := 1;
DownIndex := 2;
Caption := 'test';
OnClick := MyOnClick;
Width := Imagelist1.Width;
Height := Imagelist1.Height;
Font.Size := 12;
Font.Style := [fsBold];
end;
end;
And code
unit ImageButton;
// 2013 bummi
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
ExtCtrls, StdCtrls,ImgList;
Type
TState = (MouseIn, MouseOut, Pressed);
TImageButton = class(TGraphicControl)
private
FChangeLink:TChangeLink;
FImages: TCustomImageList;
FDownIndex: Integer;
FIndex: Integer;
FHoverIndex: Integer;
FState: TState;
FCaption: String;
FOwner: TComponent;
FAutoWidth: Boolean;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure WMLBUTTONDOWN(var Message: TMessage); message WM_LBUTTONDOWN;
procedure WMLBUTTONUP(var Message: TMessage); message WM_LBUTTONUP;
procedure SetDownIndex(const Value: Integer);
procedure SetHoverIndex(const Value: Integer);
procedure SetIndex(const Value: Integer);
procedure SetImages(const Value: TCustomImageList);
procedure SetCaption(const Value: String);
procedure ImagelistChange(Sender: TObject);
procedure SetAutoWidth(const Value: Boolean);
procedure CheckAutoWidth;
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; Override;
published
property AutoWidth:Boolean read FAutoWidth Write SetAutoWidth;
property Caption;
property DownIndex: Integer read FDownIndex Write SetDownIndex;
property Font;
property HoverIndex: Integer read FHoverIndex Write SetHoverIndex;
property Images: TCustomImageList read FImages write SetImages;
property Index: Integer read FIndex Write SetIndex;
End;
procedure Register;
implementation
procedure TImageButton.ImagelistChange(Sender:TObject);
begin
invalidate;
CheckAutoWidth;
end;
Constructor TImageButton.create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOwner := AOwner;
FState := MouseOut;
Width := 200;
Height := 200;
FChangeLink:=TChangeLink.Create;
FChangeLink.OnChange := ImagelistChange;
end;
Destructor TImageButton.Destroy;
begin
if Assigned(FImages) then FImages.UnRegisterChanges(FChangeLink);
FChangeLink.Free;
inherited Destroy;
end;
procedure TImageButton.Paint;
var
ico: TIcon;
idx: Integer;
DestRect: TRect;
L_Caption: String;
begin
inherited;
idx := -1;
if Assigned(FImages) then
begin
case FState of
MouseIn:
if FImages.Count > HoverIndex then
idx := HoverIndex;
MouseOut:
if FImages.Count > Index then
idx := Index;
Pressed:
if FImages.Count > DownIndex then
idx := DownIndex;
end;
if idx > -1 then
try
ico := TIcon.create;
FImages.GetIcon(idx, ico);
Canvas.Draw(0, 0, ico);
finally
ico.Free;
end;
end
else
begin
Canvas.Rectangle(ClientRect);
end;
Canvas.Brush.Style := bsClear;
DestRect := ClientRect;
L_Caption := Caption;
Canvas.Font.Assign(Font);
Canvas.TextRect(DestRect, L_Caption, [tfVerticalCenter, tfCenter, tfSingleLine]);
end;
procedure TImageButton.CheckAutoWidth;
begin
if FAutoWidth and Assigned(FImages) then
begin
Width := FImages.Width;
Height := FImages.Height;
end;
end;
procedure TImageButton.SetAutoWidth(const Value: Boolean);
begin
FAutoWidth := Value;
CheckAutoWidth;
end;
procedure TImageButton.SetCaption(const Value: String);
begin
FCaption := Value;
Invalidate;
end;
procedure TImageButton.SetDownIndex(const Value: Integer);
begin
FDownIndex := Value;
Invalidate;
end;
procedure TImageButton.SetHoverIndex(const Value: Integer);
begin
FHoverIndex := Value;
Invalidate;
end;
procedure TImageButton.SetImages(const Value: TCustomImageList);
begin
if Assigned(FImages) then FImages.UnRegisterChanges(FChangeLink);
FImages := Value;
if Assigned(FImages) then
begin
FImages.RegisterChanges(FChangeLink);
FImages.FreeNotification(FOwner);
CheckAutoWidth;
end;
Invalidate;
end;
procedure TImageButton.SetIndex(const Value: Integer);
begin
FIndex := Value;
Invalidate;
end;
procedure TImageButton.WMLBUTTONDOWN(var Message: TMessage);
begin
inherited;
FState := Pressed;
Invalidate;
end;
procedure TImageButton.WMLBUTTONUP(var Message: TMessage);
begin
inherited;
FState := MouseIn;
Invalidate;
end;
procedure TImageButton.CMFontChanged(var Message: TMessage);
begin
Invalidate;
end;
Procedure TImageButton.CMMouseEnter(var Message: TMessage);
Begin
inherited;
if (csDesigning in ComponentState) then
Exit;
if FState <> MouseIn then
begin
FState := MouseIn;
Invalidate;
end;
end;
Procedure TImageButton.CMMouseLeave(var Message: TMessage);
Begin
inherited;
if (csDesigning in ComponentState) then
Exit;
if FState <> MouseOut then
begin
FState := MouseOut;
Invalidate;
end;
end;
procedure TImageButton.CMTextChanged(var Message: TMessage);
begin
invalidate;
end;
procedure Register;
begin
RegisterComponents('Own', [TImageButton])
end;
end.
Will respect transparencies if use with PNG and Imagelist cd32Bit
You can inherit from TBitBtn and override CN_DRAWITEM message handler - this will create a fully normal button with focus,with any pictures you need as a background and with all window messages that buttons need (see BM_XXX messages). You can also implement a virtual method to do other kinds of buttons with just this method overriden.
Something like that:
TOwnerDrawBtn = class(TBitBtn)
private
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure CMFocusChanged(var Message: TMessage); message CM_FOCUSCHANGED;
protected
procedure DrawButton(const DrawItemStruct: TDrawItemStruct); virtual;
end;
procedure TOwnerDrawBtn.CNDrawItem(var Message: TWMDrawItem);
begin
DrawButton(Message.DrawItemStruct^);
Message.Result := Integer(True);
end;
procedure TOwnerDrawBtn.CMFocusChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TOwnerDrawBtn.DrawButton(const DrawItemStruct: TDrawItemStruct);
var
Canvas: TCanvas;
begin
Canvas := TCanvas.Create;
try
Canvas.Handle := DrawItemStruct.hDC;
//do any drawing here
finally
Canvas.Handle := 0;
Canvas.Free;
end;
end;
You Can Simply Use TJvTransparentButton from JEDI-Project JVCL .
With this component you can use single imagelist for all events and all other buttons , more events with image state , more style, Caption , Glyph, PressOffset and ... .
I'm trying to display a truly alpha blended TPanel in Delphi XE2. I've found quite a few attempts online, but none of them work correctly.
What I'm trying to achieve is a 'semi modal' form. A form that is displayed over the top of other controls with a faded background in a similar manner to that seen in web browsers.
I've got it working in a basic form, but it suffers from the following problems:
A large amount of flicker when resizing the panel.
If a control is moved over the top of the panel it leaves a trail.
Here's my efforts thus far (based on some code I found here).
unit SemiModalFormU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;
type
ISemiModalResultHandler = interface
['{0CC5A5D0-1545-4257-A936-AD777E0DAFCF}']
procedure SemiModalFormClosed(Form: TForm);
end;
TTransparentPanel = class(TCustomPanel)
private
FBackground: TBitmap;
FBlendColor: TColor;
FBlendAlpha: Byte;
procedure ColorBlend(const ACanvas: TCanvas; const ARect: TRect; const ABlendColor: TColor; const ABlendValue: Byte);
procedure SetBlendAlpha(const Value: Byte);
procedure SetBlendColor(const Value: TColor);
protected
procedure CaptureBackground;
procedure Paint; override;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure WMMove(var Message: TMessage); message WM_MOVE;
procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
procedure ClearBackground;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
property BlendColor: TColor read FBlendColor write SetBlendColor;
property BlendAlpha: Byte read FBlendAlpha write SetBlendAlpha;
property Align;
property Alignment;
property Anchors;
end;
TSemiModalForm = class(TComponent)
strict private
FFormParent: TWinControl;
FBlendColor: TColor;
FBlendAlpha: Byte;
FSemiModalResultHandler: ISemiModalResultHandler;
FForm: TForm;
FTransparentPanel: TTransparentPanel;
FOldFormOnClose: TCloseEvent;
private
procedure OnTransparentPanelResize(Sender: TObject);
procedure RepositionForm;
procedure SetFormParent(const Value: TWinControl);
procedure OnFormClose(Sender: TObject; var Action: TCloseAction);
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
procedure ShowSemiModalForm(AForm: TForm; SemiModalResultHandler: ISemiModalResultHandler); virtual;
property ModalPanel: TTransparentPanel read FTransparentPanel;
published
constructor Create(AOwner: TComponent); override;
property BlendColor: TColor read FBlendColor write FBlendColor;
property BlendAlpha: Byte read FBlendAlpha write FBlendAlpha;
property FormParent: TWinControl read FFormParent write SetFormParent;
end;
implementation
procedure TTransparentPanel.CaptureBackground;
var
canvas: TCanvas;
dc: HDC;
sourcerect: TRect;
begin
FBackground := TBitmap.Create;
with Fbackground do
begin
width := clientwidth;
height := clientheight;
end;
sourcerect.TopLeft := ClientToScreen(clientrect.TopLeft);
sourcerect.BottomRight := ClientToScreen(clientrect.BottomRight);
dc := CreateDC('DISPLAY', nil, nil, nil);
try
canvas := TCanvas.Create;
try
canvas.handle := dc;
Fbackground.Canvas.CopyRect(clientrect, canvas, sourcerect);
finally
canvas.handle := 0;
canvas.free;
end;
finally
DeleteDC(dc);
end;
end;
constructor TTransparentPanel.Create(aOwner: TComponent);
begin
inherited;
ControlStyle := controlStyle - [csSetCaption];
FBlendColor := clWhite;
FBlendAlpha := 200;
end;
destructor TTransparentPanel.Destroy;
begin
FreeAndNil(FBackground);
inherited;
end;
procedure TTransparentPanel.Paint;
begin
if csDesigning in ComponentState then
inherited
end;
procedure TTransparentPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
if (Visible) and
(HandleAllocated) and
(not (csDesigning in ComponentState)) then
begin
FreeAndNil(Fbackground);
Hide;
inherited;
Parent.Update;
Show;
end
else
inherited;
end;
procedure TTransparentPanel.WMEraseBkGnd(var msg: TWMEraseBkGnd);
var
ACanvas: TCanvas;
begin
if csDesigning in ComponentState then
inherited
else
begin
if not Assigned(FBackground) then
Capturebackground;
ACanvas := TCanvas.create;
try
ACanvas.handle := msg.DC;
ACanvas.draw(0, 0, FBackground);
ColorBlend(ACanvas, Rect(0, 0, Width, Height), FBlendColor, FBlendAlpha);
finally
FreeAndNil(ACanvas);
end;
msg.result := 1;
end;
end;
procedure TTransparentPanel.WMMove(var Message: TMessage);
begin
CaptureBackground;
end;
procedure TTransparentPanel.WMParentNotify(var Message: TWMParentNotify);
begin
CaptureBackground;
end;
procedure TTransparentPanel.ClearBackground;
begin
FreeAndNil(FBackground);
end;
procedure TTransparentPanel.ColorBlend(const ACanvas: TCanvas; const ARect: TRect;
const ABlendColor: TColor; const ABlendValue: Byte);
var
BMP: TBitmap;
begin
BMP := TBitmap.Create;
try
BMP.Canvas.Brush.Color := ABlendColor;
BMP.Width := ARect.Right - ARect.Left;
BMP.Height := ARect.Bottom - ARect.Top;
BMP.Canvas.FillRect(Rect(0,0,BMP.Width, BMP.Height));
ACanvas.Draw(ARect.Left, ARect.Top, BMP, ABlendValue);
finally
FreeAndNil(BMP);
end;
end;
procedure TTransparentPanel.SetBlendAlpha(const Value: Byte);
begin
FBlendAlpha := Value;
Paint;
end;
procedure TTransparentPanel.SetBlendColor(const Value: TColor);
begin
FBlendColor := Value;
Paint;
end;
{ TSemiModalForm }
constructor TSemiModalForm.Create(AOwner: TComponent);
begin
inherited;
FBlendColor := clWhite;
FBlendAlpha := 150;
FTransparentPanel := TTransparentPanel.Create(Self);
end;
procedure TSemiModalForm.SetFormParent(const Value: TWinControl);
begin
FFormParent := Value;
end;
procedure TSemiModalForm.ShowSemiModalForm(AForm: TForm;
SemiModalResultHandler: ISemiModalResultHandler);
begin
if FForm = nil then
begin
FForm := AForm;
FSemiModalResultHandler := SemiModalResultHandler;
FTransparentPanel.Align := alClient;
FTransparentPanel.BringToFront;
FTransparentPanel.Parent := FFormParent;
FTransparentPanel.BlendColor := FBlendColor;
FTransparentPanel.BlendAlpha := FBlendAlpha;
FTransparentPanel.OnResize := OnTransparentPanelResize;
AForm.Parent := FTransparentPanel;
FOldFormOnClose := AForm.OnClose;
AForm.OnClose := OnFormClose;
RepositionForm;
AForm.Show;
FTransparentPanel.ClearBackground;
FTransparentPanel.Visible := TRUE;
end;
end;
procedure TSemiModalForm.OnFormClose(Sender: TObject; var Action: TCloseAction);
begin
FForm.OnClose := FOldFormOnClose;
try
FForm.Visible := FALSE;
FSemiModalResultHandler.SemiModalFormClosed(FForm);
finally
FForm.Parent := nil;
FForm := nil;
FTransparentPanel.Visible := FALSE;
end;
end;
procedure TSemiModalForm.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) then
begin
if AComponent = FFormParent then
SetFormParent(nil);
end;
end;
procedure TSemiModalForm.OnTransparentPanelResize(Sender: TObject);
begin
RepositionForm;
end;
procedure TSemiModalForm.RepositionForm;
begin
FForm.Left := (FTransparentPanel.Width div 2) - (FForm.Width div 2);
FForm.Top := (FTransparentPanel.Height div 2) - (FForm.Height div 2);
end;
end.
Can anybody help me with the problems or point me to an alpha blend panel that already exists?
Thanks for all your suggestions. I've taken the input and created a new component that does exactly what I need. Here's what it looks like:
The comment that pointed me in the right direction was the one by NGLN that I upvoted. If you post it as the answer I'll accept it.
I tried to add the component code to this answer, but StackOverflow wouldn't format it correctly. However, you can download the source and a full demo application here.
The component provides the following functionality:
The semi modal form is a child of the main form. This means that it
can be tabbed to just like the other controls.
The overlay area is drawn correctly with no artefacts.
The controls under the overlay area are automatically disabled.
The semi modal form/overlay can be shown/hidden if required e.g.
switching tabs.
A SemiModalResult is passed back in an event.
There are still a number of small issues that I would like to iron out. If anybody knows how to fix them, please let me know.
When the parent form is moved or resized it needs to call the
ParentFormMoved procedure. This allows the component to
resize/reposition the overlay form. Is there any way to hook into
the parent form and detect when it is moved?
If you mimimise the main form, then restore it, the overlay form appears immediately, then the main form is animated back to it's previous position. Is there a way to detect when the main form has finished animating?
The rounded corners of the semi modal window are not too pretty. I'm
not sure there's much that can be done about this as it's down to the
rectangular region.
Your code does not show the form modally, and I wonder why you would not. But then, maybe I do not understand the term semi modal.
In any case, I think the idea to create a half-transparent form on which to show the actual dialog will do just fine:
function ShowObviousModal(AForm: TForm; AParent: TWinControl = nil): Integer;
var
Layer: TForm;
begin
if AParent = nil then
AParent := Application.MainForm;
Layer := TForm.Create(nil);
try
Layer.AlphaBlend := True;
Layer.AlphaBlendValue := 128;
Layer.BorderStyle := bsNone;
Layer.Color := clWhite;
with AParent, ClientOrigin do
SetWindowPos(Layer.Handle, HWND_TOP, X, Y, ClientWidth, ClientHeight,
SWP_SHOWWINDOW);
Result := AForm.ShowModal;
finally
Layer.Free;
end;
end;
Usage:
procedure TForm1.Button1Click(Sender: TObject);
begin
FDialog := TForm2.Create(Self);
try
if ShowObviousModal(FDialog) = mrOk then
Caption := 'OK';
finally
FDialog.Free;
end;
end;
Strictly for use in the reserved address ranges, so IPv4 is good enough. I don't know yet if I will use class A, B or C (probably C, but ...) so it would be a bonus to be able to handle all.
And extra bonus if I can also enter something like "localhost", although I can live without that.
So, minimum requirement is to specify a 192.xxx.xxx.xxx and make sure that xxx does not exceed 255.
Sure, I could knock one up with a few mask edits, but surely someone has invented that particular (FOSS) wheel before?
Note to self: if you do have to code it, this page looks useful
Windows has a built-in IP Address edit control. You can wrap that in a custom TWinControl descendant component for easy access and reuse, eg:
type
TIPAddressFieldChange = procedure(Sender: TObject; Field: Integer; Value: Integer) of object;
TIPAddress = class(TWinControl)
private
FOnFieldChange: TIPAddressFieldChange;
function GetIP: String;
function GetIsEmpty: Boolean;
procedure SetIP(const Value: String);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
public
constructor Create(Owner: TComponent); override;
procedure Clear;
property IP: String read GetIP write SetIP;
property IsEmpty: Boolean read GetIsEmpty;
published:
property OnFieldChange: TIPAddressFieldChange read FOnFieldChange write FOnFieldChange;
end;
.
uses
Commctrl;
constructor TIPAddress.Create(Owner: TComponent);
begin
inherited;
InitCommonControl(ICC_INTERNET_CLASSES};
end;
procedure TIPAddress.CreateParams(var Params: TCreateParams);
begin
inherited;
CreateSubClass(Params, WC_IPADDRESS);
Params.Style := WS_CHILD or WS_TABSTOP or WS_VISIBLE;
if NewStyleControls and Ctl3D then
begin
Params.Style := Params.Style and not WS_BORDER;
Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
end;
Params.WindowClass.style := Params.WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TIPAddress.Clear;
begin
Perform(IPM_CLEARADDRESS, 0, 0);
end;
function TIPAddress.GetIP: String;
var
dwIp: DWORD;
begin
dwIp := 0;
Perform(IPM_GETADDRESS, 0, LPARAM(#dwIp));
Result := Format('%d.%d.%d.%d', [FIRST_IPADDRESS(dwIp), SECOND_IPADDRESS(dwIp),
THIRD_IPADDRESS(dwIp), FOURTH_IPADDRESS(dwIp)]);
end;
function TIPAddress.GetIsEmpty: Boolean;
begin
Result := Perform(IPM_ISBLANK, 0, 0) <> 0;
end;
procedure TIPAddress.SetIP(const Value: String);
var
dwIP: LPARAM;
begin
with TStringList.Create do try
Delimiter := '.';
StrictDelimiter := True;
DelimitedText := Value;
Assert(Count = 4);
dwIP := MAKEIPADDRESS(StrToInt(Strings[0]), StrToInt(Strings[1]), StrToInt(Strings[2]), StrToInt(Strings[3]));
finally
Free;
end;
Perform(IPM_SETADDRESS, 0, dwIP);
end;
procedure TIPAddress.CNNotify(var Message: TWMNotify);
begin
inherited;
if (Message.NMHdr^.code = IPN_FIELDCHANGED) and Assigned(FOnFieldChange) then
begin
with PNMIPAddress(Message.NMHdr)^ do
FOnFieldChange(Self, iField, iValue);
end;
end;
procedure TIPAddress.WMGetDlgCode(var Message: TMessage);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TIPAddress.WMSetFont(var Message: TWMSetFont);
var
LF: LOGFONT;
begin
if GetObject(Message.Font, SizeOf(LF), #LF) <> 0 then
begin
Message.Font := CreateFontIndirect(LF);
inherited;
end;
end;
What about to try the TJvIPAddress from the JEDI Visual Component Library ? It has the automatic range value correction and it derives from the standard Windows IP edit box.