neoturk: ...Early trap then close window procedure ?...
Procedure TForm1.HandleMessage(var Msg:TMessage);
begin
if msg.msg = WM_CLOSE //You can insert there other message constans from windows unit.
then
begin
{Your code when user clicked close button}
showmessage('You can not close this window!');
end
else form1.wndproc(msg); //if not closed system handle the message default
end;
procedure TForm1.Create(Sender:Tobject);
begin
form1.Windowproc:=form1.handlemessage; //run handling
end;
Delphi - .....................................
neoturk: ...Keep a form always in the background ?...
(* Mit dem folgendem Code liegt die Form des
Programms diereckt auf dem Desktop, also immer
Hintergrund, selbst wenn sie den Fokus bekommt *)
protected
procedure CreateParams(var Params: TCreateParams); override;
//...
procedure TForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
if Assigned(Application.MainForm) then
begin
Params.WndParent := GetDesktopWindow;
Params.Style := WS_CHILD;
end;
end;
Delphi - .....................................
neoturk: ...Keep a form always in the background ?...
(* Mit dem folgendem Code liegt die Form des
Programms diereckt auf dem Desktop, also immer
Hintergrund, selbst wenn sie den Fokus bekommt *)
protected
procedure CreateParams(var Params: TCreateParams); override;
//...
procedure TForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
if Assigned(Application.MainForm) then
begin
Params.WndParent := GetDesktopWindow;
Params.Style := WS_CHILD;
end;
end;
Delphi - .....................................
neoturk: ...Get a bitmap of a tradiobutton ?...
{
Diese Funktion liefert ein Bitmap eines RadioButton.
Parameter:
Checked = RadioButton ausgewählt
Hot = RadioButton aktiv (funktioniert nur unter XP und
bewirkt z.B. unter Luna einen hellroten Rand)
BgColor = Hintergrundfarbe des RadioButton
Wichtig:
Die Bitmap sollte nach Ausführung der Funktion wieder freigegeben werden!
XP-Styles werden erst ab Delphi7 unterstützt.
}
Code:{$IFDEF VER150}
uses
Themes;
{$ENDIF}
function GetRadioButtonBitmap(Checked, Hot : boolean; BgColor : TColor): TBitmap;
const
CtrlState : array[boolean] of integer = (DFCS_BUTTONRADIO,
DFCS_BUTTONRADIO or DFCS_CHECKED);
var
CBRect : TRect;
{$IFDEF VER150}
Details : TThemedElementDetails;
{$ENDIF}
BgOld : TColor;
ChkBmp : TBitmap;
ThemeOK : boolean;
x, x2, y : integer;
begin
Result := nil;
try
Result := TBitmap.Create;
ChkBmp := TBitmap.Create;
ThemeOK := False;
with Result do
begin
Width := 16;
Height := 16;
with Canvas do
begin
Brush.Color := BgColor;
FillRect(ClipRect);
ChkBmp.Assign(Result);
CBRect := ClipRect;
CBRect.Top := 1;
CBRect.Left := 1;
{$IFDEF VER150}
if ThemeServices.ThemesAvailable then
begin
//ab WinXP
if Checked = True then
begin
if Hot = True then
Details := ThemeServices.GetElementDetails(tbRadioButtonCheckedHot)
else
Details :=
ThemeServices.GetElementDetails(tbRadioButtonCheckedNormal);
end
else
begin
if Hot = True then
Details :=
ThemeServices.GetElementDetails(tbRadioButtonUncheckedHot)
else
Details :=
ThemeServices.GetElementDetails(tbRadioButtonUncheckedNormal);
end;
ThemeServices.DrawElement(Handle, Details, CBRect);
//Prüfen ob es tatsächlich geklappt hat (Win2003 liefert leere Images!)
for x := 15 downto 0 do
for y := 15 downto 0 do
if ChkBmp.Canvas.Pixels[x, y] <> Pixels[x, y] then
begin
ThemeOK := True;
break;
end;
end;
{$ENDIF}
if ThemeOK = False then
begin
//alles vor WinXP
CBRect.Left := ClipRect.Left + 2;
CBRect.Right := ClipRect.Right - 1;
CBRect.Top := ClipRect.Top + 2;
CBRect.Bottom := ClipRect.Bottom - 1;
DrawFrameControl(Handle, CBRect, DFC_BUTTON, CtrlState[Checked]);
end;
end;
end;
finally
end;
end;
Delphi - .....................................
neoturk: ...Get a bitmap of a tradiobutton ?...
{
Diese Funktion liefert ein Bitmap eines RadioButton.
Parameter:
Checked = RadioButton ausgewählt
Hot = RadioButton aktiv (funktioniert nur unter XP und
bewirkt z.B. unter Luna einen hellroten Rand)
BgColor = Hintergrundfarbe des RadioButton
Wichtig:
Die Bitmap sollte nach Ausführung der Funktion wieder freigegeben werden!
XP-Styles werden erst ab Delphi7 unterstützt.
}
Code:{$IFDEF VER150}
uses
Themes;
{$ENDIF}
function GetRadioButtonBitmap(Checked, Hot : boolean; BgColor : TColor): TBitmap;
const
CtrlState : array[boolean] of integer = (DFCS_BUTTONRADIO,
DFCS_BUTTONRADIO or DFCS_CHECKED);
var
CBRect : TRect;
{$IFDEF VER150}
Details : TThemedElementDetails;
{$ENDIF}
BgOld : TColor;
ChkBmp : TBitmap;
ThemeOK : boolean;
x, x2, y : integer;
begin
Result := nil;
try
Result := TBitmap.Create;
ChkBmp := TBitmap.Create;
ThemeOK := False;
with Result do
begin
Width := 16;
Height := 16;
with Canvas do
begin
Brush.Color := BgColor;
FillRect(ClipRect);
ChkBmp.Assign(Result);
CBRect := ClipRect;
CBRect.Top := 1;
CBRect.Left := 1;
{$IFDEF VER150}
if ThemeServices.ThemesAvailable then
begin
//ab WinXP
if Checked = True then
begin
if Hot = True then
Details := ThemeServices.GetElementDetails(tbRadioButtonCheckedHot)
else
Details :=
ThemeServices.GetElementDetails(tbRadioButtonCheckedNormal);
end
else
begin
if Hot = True then
Details :=
ThemeServices.GetElementDetails(tbRadioButtonUncheckedHot)
else
Details :=
ThemeServices.GetElementDetails(tbRadioButtonUncheckedNormal);
end;
ThemeServices.DrawElement(Handle, Details, CBRect);
//Prüfen ob es tatsächlich geklappt hat (Win2003 liefert leere Images!)
for x := 15 downto 0 do
for y := 15 downto 0 do
if ChkBmp.Canvas.Pixels[x, y] <> Pixels[x, y] then
begin
ThemeOK := True;
break;
end;
end;
{$ENDIF}
if ThemeOK = False then
begin
//alles vor WinXP
CBRect.Left := ClipRect.Left + 2;
CBRect.Right := ClipRect.Right - 1;
CBRect.Top := ClipRect.Top + 2;
CBRect.Bottom := ClipRect.Bottom - 1;
DrawFrameControl(Handle, CBRect, DFC_BUTTON, CtrlState[Checked]);
end;
end;
end;
finally
end;
end;
Delphi - .....................................
neoturk: ...Show balloon tooltips in my delphi program ?...
uses
Commctrl;
procedure ShowBalloonTip(Control: TWinControl; Icon: integer; Title: pchar; Text: PWideChar;
BackCL, TextCL: TColor);
const
TOOLTIPS_CLASS = 'tooltips_class32';
TTS_ALWAYSTIP = $01;
TTS_NOPREFIX = $02;
TTS_BALLOON = $40;
TTF_SUBCLASS = $0010;
TTF_TRANSPARENT = $0100;
TTF_CENTERTIP = $0002;
TTM_ADDTOOL = $0400 + 50;
TTM_SETTITLE = (WM_USER + 32);
ICC_WIN95_CLASSES = $000000FF;
type
TOOLINFO = packed record
cbSize: Integer;
uFlags: Integer;
hwnd: THandle;
uId: Integer;
rect: TRect;
hinst: THandle;
lpszText: PWideChar;
lParam: Integer;
end;
var
hWndTip: THandle;
ti: TOOLINFO;
hWnd: THandle;
begin
hWnd := Control.Handle;
hWndTip := CreateWindow(TOOLTIPS_CLASS, nil,
WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
0, 0, 0, 0, hWnd, 0, HInstance, nil);
if hWndTip <> 0 then
begin
SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
ti.cbSize := SizeOf(ti);
ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
ti.hwnd := hWnd;
ti.lpszText := Text;
Windows.GetClientRect(hWnd, ti.rect);
SendMessage(hWndTip, TTM_SETTIPBKCOLOR, BackCL, 0);
SendMessage(hWndTip, TTM_SETTIPTEXTCOLOR, TextCL, 0);
SendMessage(hWndTip, TTM_ADDTOOL, 1, Integer(@ti));
SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowBalloonTip(Button1, 1, 'Title',
'Balloon tooltip,http://kingron.myetang.com; updated by Calin', clBlue, clNavy);
end;
Delphi - .....................................
neoturk: ...Show balloon tooltips in my delphi program ?...
uses
Commctrl;
procedure ShowBalloonTip(Control: TWinControl; Icon: integer; Title: pchar; Text: PWideChar;
BackCL, TextCL: TColor);
const
TOOLTIPS_CLASS = 'tooltips_class32';
TTS_ALWAYSTIP = $01;
TTS_NOPREFIX = $02;
TTS_BALLOON = $40;
TTF_SUBCLASS = $0010;
TTF_TRANSPARENT = $0100;
TTF_CENTERTIP = $0002;
TTM_ADDTOOL = $0400 + 50;
TTM_SETTITLE = (WM_USER + 32);
ICC_WIN95_CLASSES = $000000FF;
type
TOOLINFO = packed record
cbSize: Integer;
uFlags: Integer;
hwnd: THandle;
uId: Integer;
rect: TRect;
hinst: THandle;
lpszText: PWideChar;
lParam: Integer;
end;
var
hWndTip: THandle;
ti: TOOLINFO;
hWnd: THandle;
begin
hWnd := Control.Handle;
hWndTip := CreateWindow(TOOLTIPS_CLASS, nil,
WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
0, 0, 0, 0, hWnd, 0, HInstance, nil);
if hWndTip <> 0 then
begin
SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
ti.cbSize := SizeOf(ti);
ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
ti.hwnd := hWnd;
ti.lpszText := Text;
Windows.GetClientRect(hWnd, ti.rect);
SendMessage(hWndTip, TTM_SETTIPBKCOLOR, BackCL, 0);
SendMessage(hWndTip, TTM_SETTIPTEXTCOLOR, TextCL, 0);
SendMessage(hWndTip, TTM_ADDTOOL, 1, Integer(@ti));
SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowBalloonTip(Button1, 1, 'Title',
'Balloon tooltip,http://kingron.myetang.com; updated by Calin', clBlue, clNavy);
end;
Delphi - .....................................
neoturk: ...Flash the modal window title when user clicks the parent form ?...
{
Under windows 2000/XP,if user open a modal dialog,
when the user click the modal form's parent form,
windows can flash the modal form title bar,how to do it by delphi?
you may create base form,let you modal form inherite from the base form,
and add under codes to the base form source:
}
type
TFrmBase = class(TForm)
protected
procedure CreateParams(var Para: TCreateParams); override;
{....}
end;
{.....}
implementation
procedure TFrmBase.CreateParams(var Para: TCreateParams);
begin
inherited;
Para.WndParent := GetActiveWindow;
end;
Delphi - .....................................
neoturk: ...Flash the modal window title when user clicks the parent form ?...
{
Under windows 2000/XP,if user open a modal dialog,
when the user click the modal form's parent form,
windows can flash the modal form title bar,how to do it by delphi?
you may create base form,let you modal form inherite from the base form,
and add under codes to the base form source:
}
type
TFrmBase = class(TForm)
protected
procedure CreateParams(var Para: TCreateParams); override;
{....}
end;
{.....}
implementation
procedure TFrmBase.CreateParams(var Para: TCreateParams);
begin
inherited;
Para.WndParent := GetActiveWindow;
end;
Delphi - .....................................
neoturk: ...Set the background color of a mdi form ?...
{*******************************************************************************
*
* Hintergrundfarbe eines MDI-Formulars setzen ohne die Farbe der darauf
* liegenden Objekte wie TGroupBox oder TPageControl zu verändern.
*
* Setting the Background color of a MDI Form without changing the color
* of overlayed objects like TGroupBox or TPageControl.
*
******************************************************************************}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm1 = class(TForm)
private
FClientInstance: TFarProc;
FPrevClientProc: TFarProc;
BkBrush: HBRUSH;
procedure ClientWndProc(var Message: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
implementation
{$R *.dfm}
constructor TForm1.Create(AOwner: TComponent);
begin
inherited;
BkBrush := CreateSolidBrush(clGray);
FClientInstance := Classes.MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FClientInstance));
end;
destructor TForm1.Destroy;
begin
DeleteObject(BkBrush);
inherited;
end;
procedure TForm1.ClientWndProc(var Message: TMessage);
var
DC: HDC;
BrushOld: HBRUSH;
begin
with Message do
begin
case Msg of
WM_ERASEBKGND:
begin
DC := TWMEraseBkGnd(Message).DC;
BrushOld := SelectObject(DC, BkBrush);
FillRect(DC, ClientRect, BkBrush);
SelectObject(DC, BrushOld);
Result := 1;
end;
else
Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam);
end;
end;
end;
end.
Delphi - .....................................
neoturk: ...Set the background color of a mdi form ?...
{*******************************************************************************
*
* Hintergrundfarbe eines MDI-Formulars setzen ohne die Farbe der darauf
* liegenden Objekte wie TGroupBox oder TPageControl zu verändern.
*
* Setting the Background color of a MDI Form without changing the color
* of overlayed objects like TGroupBox or TPageControl.
*
******************************************************************************}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm1 = class(TForm)
private
FClientInstance: TFarProc;
FPrevClientProc: TFarProc;
BkBrush: HBRUSH;
procedure ClientWndProc(var Message: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
implementation
{$R *.dfm}
constructor TForm1.Create(AOwner: TComponent);
begin
inherited;
BkBrush := CreateSolidBrush(clGray);
FClientInstance := Classes.MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FClientInstance));
end;
destructor TForm1.Destroy;
begin
DeleteObject(BkBrush);
inherited;
end;
procedure TForm1.ClientWndProc(var Message: TMessage);
var
DC: HDC;
BrushOld: HBRUSH;
begin
with Message do
begin
case Msg of
WM_ERASEBKGND:
begin
DC := TWMEraseBkGnd(Message).DC;
BrushOld := SelectObject(DC, BkBrush);
FillRect(DC, ClientRect, BkBrush);
SelectObject(DC, BrushOld);
Result := 1;
end;
else
Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam);
end;
end;
end;
end.
Delphi - .....................................
neoturk: ...Create balloon tooltips ?...
{....}
uses Commctrl;
{....}
const
TTS_BALLOON = $40;
TTM_SETTITLE = (WM_USER + 32);
var
hTooltip: Cardinal;
ti: TToolInfo;
buffer : array[0..255] of char;
{....}
procedure CreateToolTips(hWnd: Cardinal);
begin
hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
if hToolTip <> 0 then
begin
SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE);
ti.cbSize := SizeOf(TToolInfo);
ti.uFlags := TTF_SUBCLASS;
ti.hInst := hInstance;
end;
end;
procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer;
Text, Title: PChar);
var
Item: THandle;
Rect: TRect;
begin
Item := hWnd;
if (Item <> 0) and (GetClientRect(Item, Rect)) then
begin
lpti.hwnd := Item;
lpti.Rect := Rect;
lpti.lpszText := Text;
SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
FillChar(buffer, SizeOf(buffer), #0);
lstrcpy(buffer, Title);
if (IconType > 3) or (IconType < 0) then IconType := 0;
SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateToolTips(Form1.Handle);
AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title');
end;
{
IconType can be:
0 - No icon
1 - Information
2 - Warning
3 - Error
}
