neoturk: ...Enable the drop shadow effect on a window [xp] ?...
{
Question:
I saw some applications that override the default window behaviour in that
way that the window display a thin transparent shadow. How to do this?
Answer:
Override the CreateParams method of your form and add the
CS_DROPSHADOW flag to the WindowClass.Style.
CS_DROPSHADOW Enables the drop shadow effect on a window.
The effect is turned on and off through SPI_SETDROPSHADOW.
Typically, this is enabled for small, short-lived windows such as
menus to emphasize their Z order relationship to other windows.
}
type
TForm1 = class(TForm)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = $00020000;
begin
inherited;
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
Delphi - .....................................
neoturk: ...Enable the drop shadow effect on a window [xp] ?...
{
Question:
I saw some applications that override the default window behaviour in that
way that the window display a thin transparent shadow. How to do this?
Answer:
Override the CreateParams method of your form and add the
CS_DROPSHADOW flag to the WindowClass.Style.
CS_DROPSHADOW Enables the drop shadow effect on a window.
The effect is turned on and off through SPI_SETDROPSHADOW.
Typically, this is enabled for small, short-lived windows such as
menus to emphasize their Z order relationship to other windows.
}
type
TForm1 = class(TForm)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = $00020000;
begin
inherited;
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
Delphi - .....................................
neoturk: ...Create transparent menus [2000-xp] ?...
var
hHookID: HHOOK;
// function to make the menu transparent
function MakeWndTrans(Wnd: HWND; nAlpha: Integer = 10): Boolean;
type
TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: COLORREF; bAlpha: Byte;
dwFlags: Longint): Longint; stdcall;
const
// Use crKey as the transparency color.
LWA_COLORKEY = 1;
// Use bAlpha to determine the opacity of the layered window..
LWA_ALPHA = 2;
WS_EX_LAYERED = $80000;
var
hUser32: HMODULE;
SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
i : Integer;
begin
Result := False;
// Here we import the function from USER32.DLL
hUser32 := GetModuleHandle('USER32.DLL');
if hUser32 <> 0 then
begin
@SetLayeredWindowAttributes := GetProcAddress(hUser32,'SetLayeredWindowAttributes');
// If the import did not succeed, make sure your app can handle it!
if @SetLayeredWindowAttributes <> nil then
begin
// Check the current state of the dialog, and then add the WS_EX_LAYERED attribute
SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE) or WS_EX_LAYERED);
// The SetLayeredWindowAttributes function sets the opacity and
// transparency color key of a layered window
SetLayeredWindowAttributes(Wnd, 0, Trunc((255 / 100) * (100 - nAlpha)), LWA_ALPHA);
Result := True;
end;
end;
end;
// hook procedure
function HookCallWndProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
const
MENU_CLASS = '#32768';
N_ALPHA = 60;
var
cwps: TCWPStruct;
lRet: THandle;
szClass: array[0..8] of char;
begin
if (nCode = HC_ACTION) then
begin
CopyMemory(@cwps, Pointer(lParam), SizeOf(CWPSTRUCT));
case cwps.message of
WM_CREATE:
begin
GetClassName(cwps.hwnd, szClass, Length(szClass)-1);
// Window name for menu is #32768
if (lstrcmpi(szClass, MENU_CLASS) = 0) then
begin
MakeWndTrans(cwps.hwnd, N_ALPHA {Alphablending});
end;
end;
end;
end;
// Call the next hook in the chain
Result := CallNextHookEx(WH_CALLWNDPROC, nCode, wParam, lParam);
end;
// Install the hook in the OnCreate Handler
procedure TForm1.FormCreate(Sender: TObject);
var
tpid: DWORD;
begin
// Retrieve the identifier of the thread that created the specified window
tpid := GetWindowThreadProcessId(Handle, nil);
// The SetWindowsHookEx function installs an application-defined
// hook procedure into a hook chain
hHookID := SetWindowsHookEx(WH_CALLWNDPROC, HookCallWndProc, 0, tpid);
end;
// Stop the hook in the OnDestroy Handler
procedure TForm1.FormDestroy(Sender: TObject);
begin
if (hHookID <> 0) then
// Removes the hook procedure
UnhookWindowsHookEx(hHookID);
end;
Delphi - .....................................
neoturk: ...Create transparent menus [2000-xp] ?...
var
hHookID: HHOOK;
// function to make the menu transparent
function MakeWndTrans(Wnd: HWND; nAlpha: Integer = 10): Boolean;
type
TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: COLORREF; bAlpha: Byte;
dwFlags: Longint): Longint; stdcall;
const
// Use crKey as the transparency color.
LWA_COLORKEY = 1;
// Use bAlpha to determine the opacity of the layered window..
LWA_ALPHA = 2;
WS_EX_LAYERED = $80000;
var
hUser32: HMODULE;
SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
i : Integer;
begin
Result := False;
// Here we import the function from USER32.DLL
hUser32 := GetModuleHandle('USER32.DLL');
if hUser32 <> 0 then
begin
@SetLayeredWindowAttributes := GetProcAddress(hUser32,'SetLayeredWindowAttributes');
// If the import did not succeed, make sure your app can handle it!
if @SetLayeredWindowAttributes <> nil then
begin
// Check the current state of the dialog, and then add the WS_EX_LAYERED attribute
SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE) or WS_EX_LAYERED);
// The SetLayeredWindowAttributes function sets the opacity and
// transparency color key of a layered window
SetLayeredWindowAttributes(Wnd, 0, Trunc((255 / 100) * (100 - nAlpha)), LWA_ALPHA);
Result := True;
end;
end;
end;
// hook procedure
function HookCallWndProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
const
MENU_CLASS = '#32768';
N_ALPHA = 60;
var
cwps: TCWPStruct;
lRet: THandle;
szClass: array[0..8] of char;
begin
if (nCode = HC_ACTION) then
begin
CopyMemory(@cwps, Pointer(lParam), SizeOf(CWPSTRUCT));
case cwps.message of
WM_CREATE:
begin
GetClassName(cwps.hwnd, szClass, Length(szClass)-1);
// Window name for menu is #32768
if (lstrcmpi(szClass, MENU_CLASS) = 0) then
begin
MakeWndTrans(cwps.hwnd, N_ALPHA {Alphablending});
end;
end;
end;
end;
// Call the next hook in the chain
Result := CallNextHookEx(WH_CALLWNDPROC, nCode, wParam, lParam);
end;
// Install the hook in the OnCreate Handler
procedure TForm1.FormCreate(Sender: TObject);
var
tpid: DWORD;
begin
// Retrieve the identifier of the thread that created the specified window
tpid := GetWindowThreadProcessId(Handle, nil);
// The SetWindowsHookEx function installs an application-defined
// hook procedure into a hook chain
hHookID := SetWindowsHookEx(WH_CALLWNDPROC, HookCallWndProc, 0, tpid);
end;
// Stop the hook in the OnDestroy Handler
procedure TForm1.FormDestroy(Sender: TObject);
begin
if (hHookID <> 0) then
// Removes the hook procedure
UnhookWindowsHookEx(hHookID);
end;
Delphi - .....................................
neoturk: ...Check or uncheck a checkbox in another window ?...
{
The function CheckCheckBox() checks or unchecks a Checkbox in another
window.
Parameter:
hApp : Handle to the parent window of the Checkbox.
ClassName: Class name of the Checkbox.
(For Delphi-Applications: TCheckBox. For C, VB,..: Checkbox)
bValue: Determines whether the check box is in the checked state.
CheckBoxNr: Number of the CheckBox (useful if there are several Checkboxes)
}
{
Die Funktion CheckCheckBox() markiert (Checked:= True) eine Checkbox in einem
fremden Fenster.
Parameter:
hApp : Handle des Fensters, auf welchem die Checkbox liegt.
ClassName: Klassenname der Checkbox.
(Bei Delphi-Anwendungen TCheckBox, bei C, VB,..: Checkbox)
bValue: Wenn True, dann wird die Checkbox markiert.
CheckBoxNr: Nummer der CheckBox (nützlich, wenn mehrere Checkboxen vorhanden sind)
("Reihenfolge der Nummern wird durch FindWindowEx bestimmt")
}
procedure CheckCheckBox(hApp: HWND; ClassName: string; bValue: Boolean; CheckBoxNr: Integer);
var
i: Word;
hCheckBox: HWND;
begin
if not IsWindow(hApp) then Exit;
for i := 0 to CheckBoxNr do
hCheckBox := FindWindowEx(hApp, hCheckBox, PChar(ClassName), nil);
if IsWindow(hCheckBox) then
SendMessage(hCheckBox, BM_SETCHECK, Integer(bValue), 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CheckCheckBox(Handle, 'TCheckBox', True, 1);
// Or / Oder
// CheckCheckBox(Handle, 'CheckBox', True, 1);
end;
Delphi - .....................................
neoturk: ...Check or uncheck a checkbox in another window ?...
{
The function CheckCheckBox() checks or unchecks a Checkbox in another
window.
Parameter:
hApp : Handle to the parent window of the Checkbox.
ClassName: Class name of the Checkbox.
(For Delphi-Applications: TCheckBox. For C, VB,..: Checkbox)
bValue: Determines whether the check box is in the checked state.
CheckBoxNr: Number of the CheckBox (useful if there are several Checkboxes)
}
{
Die Funktion CheckCheckBox() markiert (Checked:= True) eine Checkbox in einem
fremden Fenster.
Parameter:
hApp : Handle des Fensters, auf welchem die Checkbox liegt.
ClassName: Klassenname der Checkbox.
(Bei Delphi-Anwendungen TCheckBox, bei C, VB,..: Checkbox)
bValue: Wenn True, dann wird die Checkbox markiert.
CheckBoxNr: Nummer der CheckBox (nützlich, wenn mehrere Checkboxen vorhanden sind)
("Reihenfolge der Nummern wird durch FindWindowEx bestimmt")
}
procedure CheckCheckBox(hApp: HWND; ClassName: string; bValue: Boolean; CheckBoxNr: Integer);
var
i: Word;
hCheckBox: HWND;
begin
if not IsWindow(hApp) then Exit;
for i := 0 to CheckBoxNr do
hCheckBox := FindWindowEx(hApp, hCheckBox, PChar(ClassName), nil);
if IsWindow(hCheckBox) then
SendMessage(hCheckBox, BM_SETCHECK, Integer(bValue), 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CheckCheckBox(Handle, 'TCheckBox', True, 1);
// Or / Oder
// CheckCheckBox(Handle, 'CheckBox', True, 1);
end;
Delphi - .....................................
neoturk: ...Change the button captions in messagedlg ?...
function MyMessageDialog(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; Captions: array of string): Integer;
var
aMsgDlg: TForm;
i: Integer;
dlgButton: TButton;
CaptionIndex: Integer;
begin
{ Create the Dialog }
{ Dialog erzeugen }
aMsgDlg := CreateMessageDialog(Msg, DlgType, Buttons);
captionIndex := 0;
{ Loop through Objects in Dialog }
{ Über alle Objekte auf dem Dialog iterieren}
for i := 0 to aMsgDlg.ComponentCount - 1 do
begin
{ If the object is of type TButton, then }
{ Wenn es ein Button ist, dann...}
if (aMsgDlg.Components[i] is TButton) then
begin
dlgButton := TButton(aMsgDlg.Components[i]);
if CaptionIndex > High(Captions) then Break;
{ Give a new caption from our Captions array}
{ Schreibe Beschriftung entsprechend Captions array}
dlgButton.Caption := Captions[CaptionIndex];
Inc(CaptionIndex);
end;
end;
Result := aMsgDlg.ShowModal;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if MyMessageDialog('How much...?', mtConfirmation, mbOKCancel,
['1', '2']) = mrOk then
ShowMessage('"1" clicked')
else
ShowMessage('"2" clicked');
end;
Delphi - .....................................
neoturk: ...Change the button captions in messagedlg ?...
function MyMessageDialog(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; Captions: array of string): Integer;
var
aMsgDlg: TForm;
i: Integer;
dlgButton: TButton;
CaptionIndex: Integer;
begin
{ Create the Dialog }
{ Dialog erzeugen }
aMsgDlg := CreateMessageDialog(Msg, DlgType, Buttons);
captionIndex := 0;
{ Loop through Objects in Dialog }
{ Über alle Objekte auf dem Dialog iterieren}
for i := 0 to aMsgDlg.ComponentCount - 1 do
begin
{ If the object is of type TButton, then }
{ Wenn es ein Button ist, dann...}
if (aMsgDlg.Components[i] is TButton) then
begin
dlgButton := TButton(aMsgDlg.Components[i]);
if CaptionIndex > High(Captions) then Break;
{ Give a new caption from our Captions array}
{ Schreibe Beschriftung entsprechend Captions array}
dlgButton.Caption := Captions[CaptionIndex];
Inc(CaptionIndex);
end;
end;
Result := aMsgDlg.ShowModal;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if MyMessageDialog('How much...?', mtConfirmation, mbOKCancel,
['1', '2']) = mrOk then
ShowMessage('"1" clicked')
else
ShowMessage('"2" clicked');
end;
Delphi - .....................................
neoturk: ...Show my own help dialog when user clicks the bihelp border icon ?...
type
TForm1 = class(TForm)
private
procedure wmNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
procedure wmNCLButtonUp(var Msg: TWMNCLButtonUp); message WM_NCLBUTTONUP;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.wmNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
if Msg.HitTest = HTHELP then
begin
Msg.Result := 0; // swallow mouse down on biHelp border icon
end
else
inherited;
end;
procedure TForm1.wmNCLButtonUp(var Msg: TWMNCLButtonUp);
begin
if Msg.HitTest = HTHELP then
begin
Msg.Result := 0;
ShowMessage('Hi!'); // Show your help here
end
else
inherited;
end;
Delphi - .....................................
neoturk: ...Show my own help dialog when user clicks the bihelp border icon ?...
type
TForm1 = class(TForm)
private
procedure wmNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
procedure wmNCLButtonUp(var Msg: TWMNCLButtonUp); message WM_NCLBUTTONUP;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.wmNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
if Msg.HitTest = HTHELP then
begin
Msg.Result := 0; // swallow mouse down on biHelp border icon
end
else
inherited;
end;
procedure TForm1.wmNCLButtonUp(var Msg: TWMNCLButtonUp);
begin
if Msg.HitTest = HTHELP then
begin
Msg.Result := 0;
ShowMessage('Hi!'); // Show your help here
end
else
inherited;
end;
Delphi - .....................................
neoturk: ...Tile a non-mdiframe window with a backgrund bitmap ?...
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FWallpaper: TBitmap;
procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormDestroy(Sender: TObject);
begin
FWallpaper.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
// Load the bitmap
// Bild laden
if OpenDialog1.Execute then
begin
if not Assigned(FWallpaper) then
FWallpaper := TBitmap.Create;
FWallpaper.LoadFromFile(OpenDialog1.FileName);
Invalidate;
end;
end;
procedure TForm1.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
var
row, col: Integer;
begin
if not Assigned(FWallpaper) then
inherited
else
begin
// Draw the bitmap
// Das Bild zeichnen
for Row := 0 to ClientHeight div FWallpaper.Height do
for Col := 0 to ClientWidth div FWallpaper.Width do
BitBlt(Msg.Dc,
Col * FWallpaper.Width,
Row * FWallpaper.Height,
FWallpaper.Width,
FWallpaper.Height,
FWallpaper.Canvas.Handle,
0,
0,
SRCCOPY);
Msg.Result := 1;
end; { else }
end;
end.
Delphi - .....................................
neoturk: ...Tile a non-mdiframe window with a backgrund bitmap ?...
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FWallpaper: TBitmap;
procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormDestroy(Sender: TObject);
begin
FWallpaper.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
// Load the bitmap
// Bild laden
if OpenDialog1.Execute then
begin
if not Assigned(FWallpaper) then
FWallpaper := TBitmap.Create;
FWallpaper.LoadFromFile(OpenDialog1.FileName);
Invalidate;
end;
end;
procedure TForm1.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
var
row, col: Integer;
begin
if not Assigned(FWallpaper) then
inherited
else
begin
// Draw the bitmap
// Das Bild zeichnen
for Row := 0 to ClientHeight div FWallpaper.Height do
for Col := 0 to ClientWidth div FWallpaper.Width do
BitBlt(Msg.Dc,
Col * FWallpaper.Width,
Row * FWallpaper.Height,
FWallpaper.Width,
FWallpaper.Height,
FWallpaper.Canvas.Handle,
0,
0,
SRCCOPY);
Msg.Result := 1;
end; { else }
end;
end.
Delphi - .....................................
neoturk: ...Hide the minimize-maximize buttons of a form ?...
{
This article shows by example how to suppress the maximize and
minimize buttons on an form at runtime.
To disable an form's Minimize and Maximize buttons,
you need to use the SetWindowLong Windows API
function to change the style of the window.
}
{ Dieses Beispiel zeigt, wie man die Schaltflächen zur Minimierung,
Maximierung einer Form zur Laufzeit verstecken kann.
Man braucht dafür die SetWindowLong Windows API um den Stil
des Fensters zu ändern.
Der Code kann auch für non-VCL Anwendungen gebraucht werden.
}
// Add the following code to the OnCreate event
// procedure for your form (TForm1):
procedure TForm1.FormCreate(Sender: TObject);
var
l: DWORD;
begin
l := GetWindowLong(Self.Handle, GWL_STYLE);
l := l and not (WS_MINIMIZEBOX);
l := l and not (WS_MAXIMIZEBOX);
l := SetWindowLong(Self.Handle, GWL_STYLE, l);
end;
Delphi - .....................................
neoturk: ...Hide the minimize-maximize buttons of a form ?...
{
This article shows by example how to suppress the maximize and
minimize buttons on an form at runtime.
To disable an form's Minimize and Maximize buttons,
you need to use the SetWindowLong Windows API
function to change the style of the window.
}
{ Dieses Beispiel zeigt, wie man die Schaltflächen zur Minimierung,
Maximierung einer Form zur Laufzeit verstecken kann.
Man braucht dafür die SetWindowLong Windows API um den Stil
des Fensters zu ändern.
Der Code kann auch für non-VCL Anwendungen gebraucht werden.
}
// Add the following code to the OnCreate event
// procedure for your form (TForm1):
procedure TForm1.FormCreate(Sender: TObject);
var
l: DWORD;
begin
l := GetWindowLong(Self.Handle, GWL_STYLE);
l := l and not (WS_MINIMIZEBOX);
l := l and not (WS_MAXIMIZEBOX);
l := SetWindowLong(Self.Handle, GWL_STYLE, l);
end;
Delphi - .....................................
neoturk: ...Format a messagedlg ?...
procedure TForm1.Button1Click(Sender: TObject);
var
f: TForm;
begin
// Create the MessageDialog
// Den MessageDialog erstellen
f := Dialogs.CreateMessageDialog('HELLOWORLD', dialogs.mtInformation, dialogs.mbOKCancel);
// Set the backcolor to blue.
// färbt die Form blau.
f.Color := clBlue;
// Set textcolor to lime
// Färbt die Schrift lime
f.Font.Color := clLime;
// Zeigt die Form an und wartet auf den ModalResult.
// Shows the dialog and wait for the modalresult
if f.ShowModal = mrOk then
ShowMessage('OK Pressed, OK wurde gedrückt')
else
ShowMessage('Cancel pressed. Abbrechen wurde gedrückt');
end;
