mehdi_m
asked on
create balloon tooltips
Hi
I know how to make a tooltip like balloon. and when a mouse go over the component it will be activated.
I want to activate it myself; for example activate it for an unlimited times, and then disappear it.
my other problem is this; in the following code the tooltip can be set to the components that have Handle property, and will not work with components which don't have handle like label,... can not operate. how could I change it to include them.
my code is:
-------------------------- ---------- ---------- ---------- ---------- ------
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.Handl e);
AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title');
end;
{
IconType can be:
0 - No icon
1 - Information
2 - Warning
3 - Error
}
-------------------------- ---------- ---------- ---------- ---------- ------
Thank you very much.
I know how to make a tooltip like balloon. and when a mouse go over the component it will be activated.
I want to activate it myself; for example activate it for an unlimited times, and then disappear it.
my other problem is this; in the following code the tooltip can be set to the components that have Handle property, and will not work with components which don't have handle like label,... can not operate. how could I change it to include them.
my code is:
--------------------------
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
begin
CreateToolTips(Form1.Handl
AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title');
end;
{
IconType can be:
0 - No icon
1 - Information
2 - Warning
3 - Error
}
--------------------------
Thank you very much.
hello mehdi_m, , this is not so simple, a TGraphicControl (TLabel, TSpeedButton) are just a "Drawing" that Delphi does on the Parent Window DC, so you will need to move your code UP to the parent window and then set a rectangle in the TToolInfo to a Rectangle of the Graphic control, as for showing an "On Demand" tool Tip you will need to NOT use the TTF_SUBCLASS style flag and then call a WM_MOUSEMOVE as a TTM_RELAYEVENT message. .
ASKER
hi Slick812
The above code is not mine, so I don't understand all of that. can you explain more about showing an "On Demand" tool tip , "TTF_SUBCLASS" and "TTM_RELAYEVENT".
thank you for your help.
mehdi_m
The above code is not mine, so I don't understand all of that. can you explain more about showing an "On Demand" tool tip , "TTF_SUBCLASS" and "TTM_RELAYEVENT".
thank you for your help.
mehdi_m
OK, this is a rather complicated system set up to use the Tool Tips. . . I was not able to ever get the tool tip to be shown anywhere except where the cursor was at the time I called ShowCallTip , it may be posible, but I could not do it, Here is some code in a unit called ToolTipS.pas
this has several functions and procedures which I hope you can tell what they do by there names, this unit is NOT meant to be a working and functional unit for tool tips, but I am just trying to show some code to use the Tool Tip, - -
unit ToolTipS;
interface
type
TIconType = (itNone, itInfo, itWarn, itError);
function Get_hToolTip: Cardinal;
function CreateToolTips(hParent: Cardinal): Boolean;
function SetToolTipTitle(const Title: String; IconType: TIconType): Boolean;
function AddToolAutoTip(hTipWnd: Cardinal; const Text: String): Boolean;
function AddToolCallTip(const TipText: String; hOtherWnd: Cardinal): Integer;
procedure ShowCallTip(Index: Cardinal);
procedure HideCallTip;
implementation
uses
Windows, Messages, Commctrl;
const
Zero = 0;
TTS_BALLOON = $40;
TTM_SETTITLE = (WM_USER + 32);
iUseDef: Integer = Integer(CW_USEDEFAULT);
var
hTooltip: Cardinal = Zero;
hToolParent: Cardinal = Zero;
hOther: Cardinal = Zero;
aryTipText: array of String;
function Get_hToolTip: Cardinal;
begin
Result := hToolTip;
end;
function CreateToolTips(hParent: Cardinal): Boolean;
begin
if not IsWindow(hParent) then
begin
Result := False;
Exit;
end;
hToolTip := CreateWindowEx(Zero, TOOLTIPS_CLASS{'Tooltips_C lass32'}, nil,
{TTS_ALWAYSTIP or} TTS_BALLOON, iUseDef, iUseDef,
iUseDef, iUseDef, hParent, Zero, hInstance, nil);
hToolParent := hParent;
if hToolTip = Zero then
Result := False
else
Result := True;
end;
function SetToolTipTitle(const Title: String; IconType: TIconType): Boolean;
begin
if SendMessage(hToolTip, TTM_SETTITLE, Ord(IconType), Integer(PChar(Title))) = Zero then
Result := False
else
Result := True;
end;
function AddToolAutoTip(hTipWnd: Cardinal; const Text: String): Boolean;
var
InfoTool: TToolInfo;
begin
Result := False;
if (hToolTip = Zero) or (not IsWindow(hTipWnd)) then Exit;
if GetClientRect(hTipWnd, InfoTool.Rect) then
begin
with InfoTool do
begin
cbSize := SizeOf(toolInfo);
uId := Zero;
hwnd := hTipWnd;
uFlags := TTF_SUBCLASS;
hInst := Zero;
lpszText := PChar(Text);
end;
if SendMessage(hToolTip, TTM_ADDTOOL, Zero, Integer(@InfoTool)) <> Zero then
Result := True;
end;
end;
function AddToolCallTip(const TipText: String; hOtherWnd: Cardinal): Integer;
var
InfoTool: TToolInfo;
begin
Result := -1;
if (hToolTip = Zero) or (not IsWindow(hOtherWnd)) then Exit;
hOther := hOtherWnd;
setLength(aryTipText, Length(aryTipText)+1);
aryTipText[High(aryTipText )] := TipText;
if High(aryTipText) > Zero then
begin
Result := High(aryTipText);
Exit;
end;
with InfoTool do
begin
cbSize := SizeOf(toolInfo);
uId := hToolParent;
hwnd := hToolParent;
SetRect(Rect,3,3,20,18);
uFlags := TTF_IDISHWND;
hInst := hInstance;
lpszText := PChar(TipText);
end;
if SendMessage(hToolTip, TTM_ADDTOOL, Zero, Integer(@InfoTool)) <> Zero then
Result := High(aryTipText)
else
setLength(aryTipText, Zero);
end;
procedure ShowCallTip(Index: Cardinal);
var
InfoTool: TToolInfo;
Msg1: TMsg;
begin
if Integer(Index) > High(aryTipText) then Exit;
with InfoTool do
begin
cbSize := SizeOf(toolInfo);
uId := hToolParent;
hwnd := hToolParent;
SetRect(Rect,3,3,20,18);
uFlags := TTF_IDISHWND;
hInst := hInstance;
lpszText := PChar(aryTipText[Index]);
end;
SendMessage(hToolTip, TTM_UPDATETIPTEXT, Zero, Integer(@InfoTool));
Msg1.hwnd := hToolParent;
Msg1.message := WM_MOUSEMOVE;
Msg1.wParam := Zero;
Msg1.lParam := MakeLParam(5,5);
Msg1.time := GetTickCount;
Msg1.pt.x := 5;
Msg1.pt.y := 5;
ClientToScreen(hToolParent ,Msg1.pt);
SendMessage(hToolTip, TTM_RELAYEVENT, Zero, Integer(@Msg1));
end;
procedure HideCallTip;
var
Msg1: TMsg;
begin
Msg1.hwnd := hOther;
Msg1.message := WM_MOUSEMOVE;
Msg1.wParam := Zero;
Msg1.lParam := MakeLParam(5,5);
Msg1.time := GetTickCount;
Msg1.pt.x := 5;
Msg1.pt.y := 5;
ClientToScreen(hToolParent ,Msg1.pt);
SendMessage(hToolTip, TTM_RELAYEVENT, Zero, Integer(@Msg1));
Msg1.message := WM_MOUSEMOVE;
Msg1.wParam := Zero;
Msg1.lParam := MakeLParam(40,40);
Msg1.time := GetTickCount;
Msg1.pt.x := 40;
Msg1.pt.y := 40;
ClientToScreen(hToolParent ,Msg1.pt);
SendMessage(hToolTip, TTM_RELAYEVENT, Zero, Integer(@Msg1));
end;
end.
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
as I said, I could not get the tool tips to do what I wanted (show tip a a position away from the cursor), so I do not know how to do that, maybe this will help you?
this has several functions and procedures which I hope you can tell what they do by there names, this unit is NOT meant to be a working and functional unit for tool tips, but I am just trying to show some code to use the Tool Tip, - -
unit ToolTipS;
interface
type
TIconType = (itNone, itInfo, itWarn, itError);
function Get_hToolTip: Cardinal;
function CreateToolTips(hParent: Cardinal): Boolean;
function SetToolTipTitle(const Title: String; IconType: TIconType): Boolean;
function AddToolAutoTip(hTipWnd: Cardinal; const Text: String): Boolean;
function AddToolCallTip(const TipText: String; hOtherWnd: Cardinal): Integer;
procedure ShowCallTip(Index: Cardinal);
procedure HideCallTip;
implementation
uses
Windows, Messages, Commctrl;
const
Zero = 0;
TTS_BALLOON = $40;
TTM_SETTITLE = (WM_USER + 32);
iUseDef: Integer = Integer(CW_USEDEFAULT);
var
hTooltip: Cardinal = Zero;
hToolParent: Cardinal = Zero;
hOther: Cardinal = Zero;
aryTipText: array of String;
function Get_hToolTip: Cardinal;
begin
Result := hToolTip;
end;
function CreateToolTips(hParent: Cardinal): Boolean;
begin
if not IsWindow(hParent) then
begin
Result := False;
Exit;
end;
hToolTip := CreateWindowEx(Zero, TOOLTIPS_CLASS{'Tooltips_C
{TTS_ALWAYSTIP or} TTS_BALLOON, iUseDef, iUseDef,
iUseDef, iUseDef, hParent, Zero, hInstance, nil);
hToolParent := hParent;
if hToolTip = Zero then
Result := False
else
Result := True;
end;
function SetToolTipTitle(const Title: String; IconType: TIconType): Boolean;
begin
if SendMessage(hToolTip, TTM_SETTITLE, Ord(IconType), Integer(PChar(Title))) = Zero then
Result := False
else
Result := True;
end;
function AddToolAutoTip(hTipWnd: Cardinal; const Text: String): Boolean;
var
InfoTool: TToolInfo;
begin
Result := False;
if (hToolTip = Zero) or (not IsWindow(hTipWnd)) then Exit;
if GetClientRect(hTipWnd, InfoTool.Rect) then
begin
with InfoTool do
begin
cbSize := SizeOf(toolInfo);
uId := Zero;
hwnd := hTipWnd;
uFlags := TTF_SUBCLASS;
hInst := Zero;
lpszText := PChar(Text);
end;
if SendMessage(hToolTip, TTM_ADDTOOL, Zero, Integer(@InfoTool)) <> Zero then
Result := True;
end;
end;
function AddToolCallTip(const TipText: String; hOtherWnd: Cardinal): Integer;
var
InfoTool: TToolInfo;
begin
Result := -1;
if (hToolTip = Zero) or (not IsWindow(hOtherWnd)) then Exit;
hOther := hOtherWnd;
setLength(aryTipText, Length(aryTipText)+1);
aryTipText[High(aryTipText
if High(aryTipText) > Zero then
begin
Result := High(aryTipText);
Exit;
end;
with InfoTool do
begin
cbSize := SizeOf(toolInfo);
uId := hToolParent;
hwnd := hToolParent;
SetRect(Rect,3,3,20,18);
uFlags := TTF_IDISHWND;
hInst := hInstance;
lpszText := PChar(TipText);
end;
if SendMessage(hToolTip, TTM_ADDTOOL, Zero, Integer(@InfoTool)) <> Zero then
Result := High(aryTipText)
else
setLength(aryTipText, Zero);
end;
procedure ShowCallTip(Index: Cardinal);
var
InfoTool: TToolInfo;
Msg1: TMsg;
begin
if Integer(Index) > High(aryTipText) then Exit;
with InfoTool do
begin
cbSize := SizeOf(toolInfo);
uId := hToolParent;
hwnd := hToolParent;
SetRect(Rect,3,3,20,18);
uFlags := TTF_IDISHWND;
hInst := hInstance;
lpszText := PChar(aryTipText[Index]);
end;
SendMessage(hToolTip, TTM_UPDATETIPTEXT, Zero, Integer(@InfoTool));
Msg1.hwnd := hToolParent;
Msg1.message := WM_MOUSEMOVE;
Msg1.wParam := Zero;
Msg1.lParam := MakeLParam(5,5);
Msg1.time := GetTickCount;
Msg1.pt.x := 5;
Msg1.pt.y := 5;
ClientToScreen(hToolParent
SendMessage(hToolTip, TTM_RELAYEVENT, Zero, Integer(@Msg1));
end;
procedure HideCallTip;
var
Msg1: TMsg;
begin
Msg1.hwnd := hOther;
Msg1.message := WM_MOUSEMOVE;
Msg1.wParam := Zero;
Msg1.lParam := MakeLParam(5,5);
Msg1.time := GetTickCount;
Msg1.pt.x := 5;
Msg1.pt.y := 5;
ClientToScreen(hToolParent
SendMessage(hToolTip, TTM_RELAYEVENT, Zero, Integer(@Msg1));
Msg1.message := WM_MOUSEMOVE;
Msg1.wParam := Zero;
Msg1.lParam := MakeLParam(40,40);
Msg1.time := GetTickCount;
Msg1.pt.x := 40;
Msg1.pt.y := 40;
ClientToScreen(hToolParent
SendMessage(hToolTip, TTM_RELAYEVENT, Zero, Integer(@Msg1));
end;
end.
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
as I said, I could not get the tool tips to do what I wanted (show tip a a position away from the cursor), so I do not know how to do that, maybe this will help you?
ASKER
I noted your code, dear Slick812
I just want to create a window (like a ballon tooltip) and show it in a specified place (x,y) of my form. I don't think that it's so hard.
I can create a window with CreateWindow, but can not show it !
could you please help me to show a window with its handle or else?
thank you.
mehdi_m
I just want to create a window (like a ballon tooltip) and show it in a specified place (x,y) of my form. I don't think that it's so hard.
I can create a window with CreateWindow, but can not show it !
could you please help me to show a window with its handle or else?
thank you.
mehdi_m
???
I am not sure about what you want to do? Maybe you can say more what you are trying to do, It seems you want to make Ballooon hints that you have control of?
I was going from your question about the API Tool Tip and showed some code for using that in my comment, I can give more code or explanation on that if you like, , , ,
in your last comment, you seem to change the "Subject" of this question to How to show a window that you create with a CreateWindow( ) function, whch I can help you with. .
However, the Delphi coding set up (In my opinion) is not made to do this sort of thing, it is made to use a TForm for any separate "Windows" that you will need. . .
but the "Hint" or "Tool Tip" type of windows are handled by the delphi THint of the delphi Application, I have seen some components that have alternate "THint" looks like bubble and transparent, if you do not have much expeience with API window creation, you may do better with a delphi Hint Component which the maker has tested. . .
I do not mean to make this harder (more difficult) for you, but the things you may need to do to make your own Hint windows may thake some coding to do (not a Delphi object sort of thing)
I will try and help however I can. . . .
I am not sure about what you want to do? Maybe you can say more what you are trying to do, It seems you want to make Ballooon hints that you have control of?
I was going from your question about the API Tool Tip and showed some code for using that in my comment, I can give more code or explanation on that if you like, , , ,
in your last comment, you seem to change the "Subject" of this question to How to show a window that you create with a CreateWindow( ) function, whch I can help you with. .
However, the Delphi coding set up (In my opinion) is not made to do this sort of thing, it is made to use a TForm for any separate "Windows" that you will need. . .
but the "Hint" or "Tool Tip" type of windows are handled by the delphi THint of the delphi Application, I have seen some components that have alternate "THint" looks like bubble and transparent, if you do not have much expeience with API window creation, you may do better with a delphi Hint Component which the maker has tested. . .
I do not mean to make this harder (more difficult) for you, but the things you may need to do to make your own Hint windows may thake some coding to do (not a Delphi object sort of thing)
I will try and help however I can. . . .
you asked about having a window to show up using the CreateWindow API, there are several ways, but here is some code I would use to do that . The main code is in the DoPopUpWindow procedure, however I initialize and register the window Class in the forms OnCreate
main form's code -
TForm1 = class(TForm)
sbut_MakePopUpWnd: TSpeedButton;
sbut_ClosePopUp: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure sbut_MakePopUpWndClick(Sen der: TObject);
procedure sbut_ClosePopUpClick(Sende r: TObject);
private
{ Private declarations }
wClass: TWndClass;
hPopUp: THandle;
procedure DoPopUpWindow(X, Y, Width: Integer; const Caption: String);
implementation
function WndProc1(hWnd, iMsg, WParam, LParam: Integer): Integer; stdCall;
begin
case iMsg of
WM_CTLCOLORSTATIC:
begin
SetBkColor(WParam,GetSysCo lor(COLOR_ INFOBK));
Result := GetSysColorBrush(COLOR_INF OBK);
Exit;
end;
WM_LBUTTONUP: PostMessage(hWnd, WM_CLOSE, 0,0);
end;
Result := DefWindowProc(hWnd, iMsg, WParam, LParam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
hPopUp := 0;
ZeroMemory(@wClass, SizeOf(wClass));
with wClass do
begin
Style := CS_SAVEBITS;
hInstance := sysInit.hInstance;
lpfnWndProc := @WndProc1;
hbrBackground := COLOR_INFOBK+1;
lpszClassName := 'Some class name here';
hCursor := LoadCursor(0,IDC_ARROW);
end;
windows.RegisterClass(wCla ss);
end;
procedure TForm1.DoPopUpWindow(X, Y, Width: Integer; const Caption: String);
var
Rect1: TRect;
scnDC: THandle;
begin
Rect1 := Rect(3,3,Width-6,6);
scnDC := GetDC(0);
SelectObject(scnDC, GetStockObject(ANSI_VAR_FO NT));
// you will need to have a way to size the window according to the amount of text in it
DrawText(scnDC,PChar(Capti on),-1, Rect1, DT_WORDBREAK or DT_EDITCONTROL or DT_CALCRECT);
// I use the DrawText function with the DT_CALCRECT to calculate the rectangle
ReleaseDC(0, scnDC);
// add 6 for the border of 3
hPopUp := CreateWindow(wClass.lpszCl assName,' ', WS_POPUP or WS_BORDER{or WS_VISIBLE},
X, Y, Rect1.Right+6, Rect1.Bottom+5, Form1.Handle, 0, hInstance, nil);
// be sure to have a Forms's handle as the parent handle in CreateWindow
if hPopUp = 0 then
begin
ShowMessage('NO hPopup');
Exit;
end;
// I use a STATIC for text display, but you can just draw on the DC instead
SendMessage(
CreateWindow('STATIC',PCha r(Caption) ,WS_VISIBL E or WS_CHILD,3,3,Rect1.Right,
Rect1.Bottom-1, hPopUp, 44, hInstance, nil)
, WM_SETFONT, GetStockObject(ANSI_VAR_FO NT), 0);
end;
procedure TForm1.sbut_MakePopUpWndCl ick(Sender : TObject);
begin
DoPopUpWindow(Left+40,Top+ 50, 160, 'This is a PopUp window with text on it, to read'#10'and some more text');
// the system uses the AnimateWindow to show a Tip
// the AW_BLEND is not avaiable in window systems older than Win 2000
if not AnimateWindow(hPopUp, 120, AW_BLEND {AW_SLIDE or AW_VER_POSITIVE}) then
ShowWindow(hPopUp, SW_SHOWNA);
end;
procedure TForm1.sbut_ClosePopUpClic k(Sender: TObject);
begin
if hPopUp <> 0 then
begin
AnimateWindow(hPopUp, 120, AW_HIDE or AW_BLEND {AW_SLIDE or AW_VER_NEGATIVE});
DestroyWindow(hPopUp);
hPopUp := 0;
end;
end;
- - - - - - - - - - - - - - - - - - - - - - -
this does not do any "Shape" like a Balloon, but just shows a rectangle hint type of window
main form's code -
TForm1 = class(TForm)
sbut_MakePopUpWnd: TSpeedButton;
sbut_ClosePopUp: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure sbut_MakePopUpWndClick(Sen
procedure sbut_ClosePopUpClick(Sende
private
{ Private declarations }
wClass: TWndClass;
hPopUp: THandle;
procedure DoPopUpWindow(X, Y, Width: Integer; const Caption: String);
implementation
function WndProc1(hWnd, iMsg, WParam, LParam: Integer): Integer; stdCall;
begin
case iMsg of
WM_CTLCOLORSTATIC:
begin
SetBkColor(WParam,GetSysCo
Result := GetSysColorBrush(COLOR_INF
Exit;
end;
WM_LBUTTONUP: PostMessage(hWnd, WM_CLOSE, 0,0);
end;
Result := DefWindowProc(hWnd, iMsg, WParam, LParam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
hPopUp := 0;
ZeroMemory(@wClass, SizeOf(wClass));
with wClass do
begin
Style := CS_SAVEBITS;
hInstance := sysInit.hInstance;
lpfnWndProc := @WndProc1;
hbrBackground := COLOR_INFOBK+1;
lpszClassName := 'Some class name here';
hCursor := LoadCursor(0,IDC_ARROW);
end;
windows.RegisterClass(wCla
end;
procedure TForm1.DoPopUpWindow(X, Y, Width: Integer; const Caption: String);
var
Rect1: TRect;
scnDC: THandle;
begin
Rect1 := Rect(3,3,Width-6,6);
scnDC := GetDC(0);
SelectObject(scnDC, GetStockObject(ANSI_VAR_FO
// you will need to have a way to size the window according to the amount of text in it
DrawText(scnDC,PChar(Capti
// I use the DrawText function with the DT_CALCRECT to calculate the rectangle
ReleaseDC(0, scnDC);
// add 6 for the border of 3
hPopUp := CreateWindow(wClass.lpszCl
X, Y, Rect1.Right+6, Rect1.Bottom+5, Form1.Handle, 0, hInstance, nil);
// be sure to have a Forms's handle as the parent handle in CreateWindow
if hPopUp = 0 then
begin
ShowMessage('NO hPopup');
Exit;
end;
// I use a STATIC for text display, but you can just draw on the DC instead
SendMessage(
CreateWindow('STATIC',PCha
Rect1.Bottom-1, hPopUp, 44, hInstance, nil)
, WM_SETFONT, GetStockObject(ANSI_VAR_FO
end;
procedure TForm1.sbut_MakePopUpWndCl
begin
DoPopUpWindow(Left+40,Top+
// the system uses the AnimateWindow to show a Tip
// the AW_BLEND is not avaiable in window systems older than Win 2000
if not AnimateWindow(hPopUp, 120, AW_BLEND {AW_SLIDE or AW_VER_POSITIVE}) then
ShowWindow(hPopUp, SW_SHOWNA);
end;
procedure TForm1.sbut_ClosePopUpClic
begin
if hPopUp <> 0 then
begin
AnimateWindow(hPopUp, 120, AW_HIDE or AW_BLEND {AW_SLIDE or AW_VER_NEGATIVE});
DestroyWindow(hPopUp);
hPopUp := 0;
end;
end;
- - - - - - - - - - - - - - - - - - - - - - -
this does not do any "Shape" like a Balloon, but just shows a rectangle hint type of window
ASKER
Dear Slick812
I test your code but function "AnimateWindow" returns False and nothing happens.
thank you.
mehdi_m
I test your code but function "AnimateWindow" returns False and nothing happens.
thank you.
mehdi_m
OK, as far as I know the AnimateWindow function works, , but I also added the code for a False AnimateWindow, it just has the
ShowWindow(hPopUp, SW_SHOWNA);
------
if not AnimateWindow(hPopUp, 120, AW_BLEND {AW_SLIDE or AW_VER_POSITIVE}) then
ShowWindow(hPopUp, SW_SHOWNA);
I tested this code i both win XP and win 98, and it worked for me, the main code for the winow creation is in the procedure -
procedure TForm1.DoPopUpWindow(X, Y, Width: Integer; const Caption: String);
but I do not know what to help you with, since it worked for me, and I can not find a problem if I do not have one?
If you are interested in the windows API window creation using the CreateWindow( ) function, you might look at the web site at -
http://www.angelfire.com/hi5/delphizeus/index.html
which has some lessons on how to use the create window, but this is not an easy thing to understand, , , , , , it may be faster for you to just get a "Hint Component" and use that component, or copy some code from it
ShowWindow(hPopUp, SW_SHOWNA);
------
if not AnimateWindow(hPopUp, 120, AW_BLEND {AW_SLIDE or AW_VER_POSITIVE}) then
ShowWindow(hPopUp, SW_SHOWNA);
I tested this code i both win XP and win 98, and it worked for me, the main code for the winow creation is in the procedure -
procedure TForm1.DoPopUpWindow(X, Y, Width: Integer; const Caption: String);
but I do not know what to help you with, since it worked for me, and I can not find a problem if I do not have one?
If you are interested in the windows API window creation using the CreateWindow( ) function, you might look at the web site at -
http://www.angelfire.com/hi5/delphizeus/index.html
which has some lessons on how to use the create window, but this is not an easy thing to understand, , , , , , it may be faster for you to just get a "Hint Component" and use that component, or copy some code from it
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
hi
Thank you for introducing me that useful site. I found the component that I looking for. (TBalloonControl; the hint with controling not to disapear and popup on demand meaning with code)
I will distribute it here for others who read this question and may like to have it:
the whole component can be downloaded from this url ; http://www.torry.net/vcl/misceff/hints/jwbballoon.zip
this is the component source code (Balloon.pas)
//------------------------ ---------- ---------- ---------- ----------
{
Balloon - using Balloon-shaped windows in your Delphi programs
Copyright (C) 2003 JWB Software
Web: http://people.zeelandnet.nl/famboek/delphi/
Email: jwbsoftware@zeelandnet.nl
}
Unit Balloon;
Interface
Uses
Forms, Classes, Controls, StdCtrls, ExtCtrls, Windows, Graphics,
Messages, SysUtils;
Type
TBalloonType = (blnInfo, blnError, blnWarning);
TBalloonHoriz = (blnLeft, blnMiddle, blnRight);
TBalloonVert = (blnTop, blnCenter, blnBottom);
TBalloonPosition = (blnArrowTopLeft, blnArrowTopRight, blnArrowBottomLeft, blnArrowBottomRight);
Type
TBalloonControl = class(TComponent)
private
FTitle: string;
FText: TStringList;
FDuration, FPixelCoordinateX, FPixelCoordinateY: Integer;
FHorizontal: TBalloonHoriz;
FVertical: TBalloonVert;
FPosition: TBalloonPosition;
FControl: TWinControl;
FBalloonType: TBalloonType;
procedure SetText(Value: TStringList);
public
procedure ShowControlBalloon;
procedure ShowPixelBalloon;
published
property Text: TStringList read FText write SetText;
property Title: string read FTitle write FTitle;
property Duration: Integer read FDuration write FDuration;
property Horizontal: TBalloonHoriz read FHorizontal write FHorizontal;
property Vertical: TBalloonVert read FVertical write FVertical;
property Position: TBalloonPosition read FPosition write FPosition;
property Control: TWinControl read FControl write FControl;
property PixelCoordinateX: Integer read FPixelCoordinateX write FPixelCoordinateX;
property PixelCoordinateY: Integer read FPixelCoordinateY write FPixelCoordinateY;
property BalloonType: TBalloonType read FBalloonType write FBalloonType;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
Type
TBalloon = class(TCustomForm)
private
lblTitle: TLabel;
lblText: TLabel;
pnlAlign: TPanel;
iconBitmap: TImage;
tmrExit: TTimer;
procedure FormPaint(Sender: TObject);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure OnMouseClick(Sender: TObject);
procedure OnExitTimer(Sender: TObject);
procedure OnChange(Sender: TObject);
procedure WndProc(var message: TMessage); override;
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
procedure ShowBalloon(blnLeft, blnTop: Integer; blnTitle, blnText: string; blnType: TBalloonType; blnDuration: Integer; blnPosition: TBalloonPosition);
procedure ShowControlBalloon(blnCont rol: TWinControl; blnHoriz: TBalloonHoriz; blnVert: TBalloonVert; blnTitle, blnText: string; blnType: TBalloonType; blnDuration: Integer);
end;
procedure register;
implementation
{$R balloon.res}
procedure register;
begin
RegisterComponents('Compon entsX', [TBalloonControl]);
end;
constructor TBalloonControl.Create(AOw ner: TComponent);
begin
inherited;
FText := TStringList.Create;
end;
destructor TBalloonControl.Destroy;
begin
FText.Free;
Inherited;
end;
procedure TBalloonControl.SetText(Va lue: TStringList);
begin
FText.Assign(Value);
end;
Procedure TBalloonControl.ShowContro lBalloon() ;
var
Balloon: TBalloon;
begin
Balloon := TBalloon.CreateNew(Owner);
Balloon.ShowControlBalloon (FControl, FHorizontal, FVertical, FTitle, Trim(FText.Text), FBalloonType, FDuration);
end;
procedure TBalloonControl.ShowPixelB alloon();
var
Balloon: TBalloon;
begin
Balloon := TBalloon.CreateNew(nil);
Balloon.ShowBalloon(FPixel Coordinate X, FPixelCoordinateY, FTitle, Trim(FText.Text), FBalloonType, FDuration, FPosition);
end;
procedure TBalloon.CreateParams(Var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := (Params.Style and not WS_CAPTION) or WS_POPUP;
Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW or WS_EX_NOACTIVATE or WS_EX_TOPMOST;
Params.WndParent := GetDesktopWindow;
end;
procedure TBalloon.OnMouseClick(Send er: TObject);
begin
Release;
end;
procedure TBalloon.OnExitTimer(Sende r: TObject);
begin
Release;
end;
Procedure TBalloon.OnChange(Sender: TObject);
begin
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
end;
procedure TBalloon.WndProc(var message: TMessage);
begin
if (message.Msg = WM_SIZE) and (message.WParam = SIZE_MINIMIZED) then
Show;
inherited;
end;
Constructor TBalloon.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
begin
inherited;
OnActivate := OnChange;
OnDeactivate := OnChange;
OnShow := OnChange;
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
OnPaint := FormPaint;
Color := clInfoBk;
Font.Name := 'Tahoma';
pnlAlign := TPanel.Create(Self);
lblTitle := TLabel.Create(Self);
lblText := TLabel.Create(Self);
iconBitmap := TImage.Create(Self);
tmrExit := TTimer.Create(Self);
OnClick := OnMouseClick;
iconBitmap.OnClick := OnMouseClick;
pnlAlign.OnClick := OnMouseClick;
lblTitle.OnClick := OnMouseClick;
lblText.OnClick := OnMouseClick;
lblTitle.Parent := Self;
lblTitle.ParentColor := True;
lblTitle.ParentFont := True;
lblTitle.AutoSize := True;
lblTitle.Font.Style := [fsBold];
lblTitle.Left := 34;
lblTitle.Top := 12;
lblText.Parent := Self;
lblText.ParentColor := True;
lblText.ParentFont := True;
lblText.AutoSize := True;
lblText.Left := 10;
iconBitmap.Parent := Self;
iconBitmap.Transparent := True;
iconBitmap.Left := 10;
iconBitmap.Top := 10;
tmrExit.Enabled := False;
tmrExit.Interval := 0;
tmrExit.OnTimer := OnExitTimer;
end;
Procedure TBalloon.FormPaint(Sender: TObject);
var
TempRegion: HRGN;
begin
with Canvas.Brush do
begin
Color := clBlack;
Style := bsSolid;
end;
TempRegion := CreateRectRgn(0,0,1,1);
GetWindowRgn(Handle, TempRegion);
FrameRgn(Canvas.Handle, TempRegion, Canvas.Brush.handle, 1, 1);
DeleteObject(TempRegion);
end;
Procedure TBalloon.ShowControlBalloo n(blnContr ol: TWinControl; blnHoriz: TBalloonHoriz; blnVert: TBalloonVert; blnTitle, blnText: string; blnType: TBalloonType; blnDuration: Integer);
Var
Rect: TRect;
blnPosLeft, blnPosTop: Integer;
blnPosition: TBalloonPosition;
begin
GetWindowRect(blnControl.H andle, Rect);
blnPosTop := 0;
blnPosLeft := 0;
if blnVert = blnTop then
blnPosTop := Rect.Top;
if blnVert = blnCenter then
blnPosTop := Rect.Top + Round((Rect.Bottom - Rect.Top) / 2);
if blnVert = blnBottom then
blnPosTop := Rect.Bottom;
if blnHoriz = blnLeft then
blnPosLeft := Rect.Left;
if blnHoriz = blnMiddle then
blnPosLeft := Rect.Left + Round((Rect.Right - Rect.Left) / 2);
if blnHoriz = blnRight then
blnPosLeft := Rect.Right;
blnPosition := blnArrowBottomRight;
if ((blnHoriz = blnRight) and (blnVert = blnBottom)) or ((blnHoriz = blnMiddle) and (blnVert = blnBottom)) then
blnPosition := blnArrowBottomRight;
if (blnHoriz = blnLeft) and (blnVert = blnBottom) or ((blnHoriz = blnLeft) and (blnVert = blnCenter)) then
blnPosition := blnArrowBottomLeft;
if (blnHoriz = blnLeft) and (blnVert = blnTop) or ((blnHoriz = blnMiddle) and (blnVert = blnTop)) then
blnPosition := blnArrowTopLeft;
if (blnHoriz = blnRight) and (blnVert = blnTop) or ((blnHoriz = blnRight) and (blnVert = blnCenter)) then
blnPosition := blnArrowTopRight;
ShowBalloon(blnPosLeft, blnPosTop, blnTitle, blnText, blnType, blnDuration, blnPosition);
end;
procedure TBalloon.ShowBalloon(blnLe ft, blnTop: Integer; blnTitle, blnText: string; blnType: TBalloonType; blnDuration: Integer; blnPosition: TBalloonPosition);
var
ArrowHeight, ArrowWidth: Integer;
FormRegion, ArrowRegion: HRGN;
Arrow: array [0..2] of TPoint;
ResName: string;
begin
ArrowHeight := 20;
ArrowWidth := 20;
lblTitle.Caption := blnTitle;
if blnPosition = blnArrowBottomRight then
lblTitle.Top := lblTitle.Top + ArrowHeight;
if blnPosition = blnArrowBottomLeft then
lblTitle.Top := lblTitle.Top + ArrowHeight;
lblText.Top := lblTitle.Top + lblTitle.Height + 8;
lblText.Caption := blnText;
if blnPosition = blnArrowBottomRight then
iconBitmap.Top := iconBitmap.Top + ArrowHeight;
if blnPosition = blnArrowBottomLeft then
iconBitmap.Top := iconBitmap.Top + ArrowHeight;
case blnType Of
blnError:
ResName := 'ERROR';
blnInfo:
ResName := 'INFO';
blnWarning:
ResName := 'WARNING';
else
ResName := 'INFO';
end;
iconBitmap.Picture.Bitmap. LoadFromRe sourceName (HInstance , ResName);
if blnPosition = blnArrowBottomRight then
ClientHeight := lblText.Top + lblText.Height + 10;
if blnPosition = blnArrowBottomLeft then
ClientHeight := lblText.Top + lblText.Height + 10;
if blnPosition = blnArrowTopLeft then
ClientHeight := lblText.Top + lblText.Height + 10 + ArrowHeight;
if blnPosition = blnArrowTopRight then
ClientHeight := lblText.Top + lblText.Height + 10 + ArrowHeight;
if (lblTitle.Left + lblTitle.Width) > (lblText.Left + lblText.Width) then
Width := lblTitle.Left + lblTitle.Width + 10
else
Width := lblText.Left + lblText.Width + 10;
if blnPosition = blnArrowTopLeft then
begin
Left := blnLeft - (Width - 20);
Top := blnTop - (Height);
end;
if blnPosition = blnArrowTopRight then
begin
Left := blnLeft - 20;
Top := blnTop - (Height);
end;
if blnPosition = blnArrowBottomRight then
begin
Left := blnLeft - 20;
Top := blnTop - 2;
end;
if blnPosition = blnArrowBottomLeft then
begin
Left := blnLeft - (Width - 20);
Top := blnTop - 2;
end;
FormRegion := 0;
if blnPosition = blnArrowTopLeft then
begin
FormRegion := CreateRoundRectRgn(0, 0, Width, Height - (ArrowHeight - 2), 7, 7);
Arrow[0] := Point(Width - ArrowWidth - 20, Height - ArrowHeight);
Arrow[1] := Point(Width - 20, Height);
Arrow[2] := Point(Width - 20, Height - ArrowHeight);
end;
if blnPosition = blnArrowTopRight then
begin
FormRegion := CreateRoundRectRgn(0, 0, Width, Height - (ArrowHeight - 2), 7, 7);
Arrow[0] := Point(20, Height - ArrowHeight);
Arrow[1] := Point(20, Height);
Arrow[2] := Point(20 + ArrowWidth, Height - ArrowHeight);
end;
if blnPosition = blnArrowBottomRight then
begin
FormRegion := CreateRoundRectRgn(0, ArrowHeight + 2, Width, Height, 7, 7);
Arrow[0] := Point(20, 2);
Arrow[1] := Point(20, ArrowHeight + 2);
Arrow[2] := Point(20 + ArrowWidth, ArrowHeight + 2);
end;
if blnPosition = blnArrowBottomLeft then
begin
FormRegion := CreateRoundRectRgn(0, ArrowHeight + 2, Width, Height, 7, 7);
Arrow[0] := Point(Width - 20, 2);
Arrow[1] := Point(Width - 20, ArrowHeight + 2);
Arrow[2] := Point(Width - 20 - ArrowWidth, ArrowHeight + 2);
end;
ArrowRegion := CreatePolygonRgn(Arrow, 3, WINDING);
CombineRgn(FormRegion, FormRegion, ArrowRegion, RGN_OR);
DeleteObject(ArrowRegion);
SetWindowRgn(Handle, FormRegion, True);
Visible := False;
ShowWindow(Handle, SW_SHOWNOACTIVATE);
Visible := True;
tmrExit.Interval := blnDuration * 1000;
tmrExit.Enabled := True;
end;
end.
//------------------------ ---------- ---------- ---------- ----------
it has a property named Delay for specifying how long does it take for hint to disapear, or you can set it to zero for avoiding from disapearing the hint.
at last, I thank you again Slickers for your helps. the pings are yours.
mehdi_m
Thank you for introducing me that useful site. I found the component that I looking for. (TBalloonControl; the hint with controling not to disapear and popup on demand meaning with code)
I will distribute it here for others who read this question and may like to have it:
the whole component can be downloaded from this url ; http://www.torry.net/vcl/misceff/hints/jwbballoon.zip
this is the component source code (Balloon.pas)
//------------------------
{
Balloon - using Balloon-shaped windows in your Delphi programs
Copyright (C) 2003 JWB Software
Web: http://people.zeelandnet.nl/famboek/delphi/
Email: jwbsoftware@zeelandnet.nl
}
Unit Balloon;
Interface
Uses
Forms, Classes, Controls, StdCtrls, ExtCtrls, Windows, Graphics,
Messages, SysUtils;
Type
TBalloonType = (blnInfo, blnError, blnWarning);
TBalloonHoriz = (blnLeft, blnMiddle, blnRight);
TBalloonVert = (blnTop, blnCenter, blnBottom);
TBalloonPosition = (blnArrowTopLeft, blnArrowTopRight, blnArrowBottomLeft, blnArrowBottomRight);
Type
TBalloonControl = class(TComponent)
private
FTitle: string;
FText: TStringList;
FDuration, FPixelCoordinateX, FPixelCoordinateY: Integer;
FHorizontal: TBalloonHoriz;
FVertical: TBalloonVert;
FPosition: TBalloonPosition;
FControl: TWinControl;
FBalloonType: TBalloonType;
procedure SetText(Value: TStringList);
public
procedure ShowControlBalloon;
procedure ShowPixelBalloon;
published
property Text: TStringList read FText write SetText;
property Title: string read FTitle write FTitle;
property Duration: Integer read FDuration write FDuration;
property Horizontal: TBalloonHoriz read FHorizontal write FHorizontal;
property Vertical: TBalloonVert read FVertical write FVertical;
property Position: TBalloonPosition read FPosition write FPosition;
property Control: TWinControl read FControl write FControl;
property PixelCoordinateX: Integer read FPixelCoordinateX write FPixelCoordinateX;
property PixelCoordinateY: Integer read FPixelCoordinateY write FPixelCoordinateY;
property BalloonType: TBalloonType read FBalloonType write FBalloonType;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
Type
TBalloon = class(TCustomForm)
private
lblTitle: TLabel;
lblText: TLabel;
pnlAlign: TPanel;
iconBitmap: TImage;
tmrExit: TTimer;
procedure FormPaint(Sender: TObject);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure OnMouseClick(Sender: TObject);
procedure OnExitTimer(Sender: TObject);
procedure OnChange(Sender: TObject);
procedure WndProc(var message: TMessage); override;
public
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
procedure ShowBalloon(blnLeft, blnTop: Integer; blnTitle, blnText: string; blnType: TBalloonType; blnDuration: Integer; blnPosition: TBalloonPosition);
procedure ShowControlBalloon(blnCont
end;
procedure register;
implementation
{$R balloon.res}
procedure register;
begin
RegisterComponents('Compon
end;
constructor TBalloonControl.Create(AOw
begin
inherited;
FText := TStringList.Create;
end;
destructor TBalloonControl.Destroy;
begin
FText.Free;
Inherited;
end;
procedure TBalloonControl.SetText(Va
begin
FText.Assign(Value);
end;
Procedure TBalloonControl.ShowContro
var
Balloon: TBalloon;
begin
Balloon := TBalloon.CreateNew(Owner);
Balloon.ShowControlBalloon
end;
procedure TBalloonControl.ShowPixelB
var
Balloon: TBalloon;
begin
Balloon := TBalloon.CreateNew(nil);
Balloon.ShowBalloon(FPixel
end;
procedure TBalloon.CreateParams(Var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := (Params.Style and not WS_CAPTION) or WS_POPUP;
Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW or WS_EX_NOACTIVATE or WS_EX_TOPMOST;
Params.WndParent := GetDesktopWindow;
end;
procedure TBalloon.OnMouseClick(Send
begin
Release;
end;
procedure TBalloon.OnExitTimer(Sende
begin
Release;
end;
Procedure TBalloon.OnChange(Sender: TObject);
begin
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
end;
procedure TBalloon.WndProc(var message: TMessage);
begin
if (message.Msg = WM_SIZE) and (message.WParam = SIZE_MINIMIZED) then
Show;
inherited;
end;
Constructor TBalloon.CreateNew(AOwner:
begin
inherited;
OnActivate := OnChange;
OnDeactivate := OnChange;
OnShow := OnChange;
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
OnPaint := FormPaint;
Color := clInfoBk;
Font.Name := 'Tahoma';
pnlAlign := TPanel.Create(Self);
lblTitle := TLabel.Create(Self);
lblText := TLabel.Create(Self);
iconBitmap := TImage.Create(Self);
tmrExit := TTimer.Create(Self);
OnClick := OnMouseClick;
iconBitmap.OnClick := OnMouseClick;
pnlAlign.OnClick := OnMouseClick;
lblTitle.OnClick := OnMouseClick;
lblText.OnClick := OnMouseClick;
lblTitle.Parent := Self;
lblTitle.ParentColor := True;
lblTitle.ParentFont := True;
lblTitle.AutoSize := True;
lblTitle.Font.Style := [fsBold];
lblTitle.Left := 34;
lblTitle.Top := 12;
lblText.Parent := Self;
lblText.ParentColor := True;
lblText.ParentFont := True;
lblText.AutoSize := True;
lblText.Left := 10;
iconBitmap.Parent := Self;
iconBitmap.Transparent := True;
iconBitmap.Left := 10;
iconBitmap.Top := 10;
tmrExit.Enabled := False;
tmrExit.Interval := 0;
tmrExit.OnTimer := OnExitTimer;
end;
Procedure TBalloon.FormPaint(Sender:
var
TempRegion: HRGN;
begin
with Canvas.Brush do
begin
Color := clBlack;
Style := bsSolid;
end;
TempRegion := CreateRectRgn(0,0,1,1);
GetWindowRgn(Handle, TempRegion);
FrameRgn(Canvas.Handle, TempRegion, Canvas.Brush.handle, 1, 1);
DeleteObject(TempRegion);
end;
Procedure TBalloon.ShowControlBalloo
Var
Rect: TRect;
blnPosLeft, blnPosTop: Integer;
blnPosition: TBalloonPosition;
begin
GetWindowRect(blnControl.H
blnPosTop := 0;
blnPosLeft := 0;
if blnVert = blnTop then
blnPosTop := Rect.Top;
if blnVert = blnCenter then
blnPosTop := Rect.Top + Round((Rect.Bottom - Rect.Top) / 2);
if blnVert = blnBottom then
blnPosTop := Rect.Bottom;
if blnHoriz = blnLeft then
blnPosLeft := Rect.Left;
if blnHoriz = blnMiddle then
blnPosLeft := Rect.Left + Round((Rect.Right - Rect.Left) / 2);
if blnHoriz = blnRight then
blnPosLeft := Rect.Right;
blnPosition := blnArrowBottomRight;
if ((blnHoriz = blnRight) and (blnVert = blnBottom)) or ((blnHoriz = blnMiddle) and (blnVert = blnBottom)) then
blnPosition := blnArrowBottomRight;
if (blnHoriz = blnLeft) and (blnVert = blnBottom) or ((blnHoriz = blnLeft) and (blnVert = blnCenter)) then
blnPosition := blnArrowBottomLeft;
if (blnHoriz = blnLeft) and (blnVert = blnTop) or ((blnHoriz = blnMiddle) and (blnVert = blnTop)) then
blnPosition := blnArrowTopLeft;
if (blnHoriz = blnRight) and (blnVert = blnTop) or ((blnHoriz = blnRight) and (blnVert = blnCenter)) then
blnPosition := blnArrowTopRight;
ShowBalloon(blnPosLeft, blnPosTop, blnTitle, blnText, blnType, blnDuration, blnPosition);
end;
procedure TBalloon.ShowBalloon(blnLe
var
ArrowHeight, ArrowWidth: Integer;
FormRegion, ArrowRegion: HRGN;
Arrow: array [0..2] of TPoint;
ResName: string;
begin
ArrowHeight := 20;
ArrowWidth := 20;
lblTitle.Caption := blnTitle;
if blnPosition = blnArrowBottomRight then
lblTitle.Top := lblTitle.Top + ArrowHeight;
if blnPosition = blnArrowBottomLeft then
lblTitle.Top := lblTitle.Top + ArrowHeight;
lblText.Top := lblTitle.Top + lblTitle.Height + 8;
lblText.Caption := blnText;
if blnPosition = blnArrowBottomRight then
iconBitmap.Top := iconBitmap.Top + ArrowHeight;
if blnPosition = blnArrowBottomLeft then
iconBitmap.Top := iconBitmap.Top + ArrowHeight;
case blnType Of
blnError:
ResName := 'ERROR';
blnInfo:
ResName := 'INFO';
blnWarning:
ResName := 'WARNING';
else
ResName := 'INFO';
end;
iconBitmap.Picture.Bitmap.
if blnPosition = blnArrowBottomRight then
ClientHeight := lblText.Top + lblText.Height + 10;
if blnPosition = blnArrowBottomLeft then
ClientHeight := lblText.Top + lblText.Height + 10;
if blnPosition = blnArrowTopLeft then
ClientHeight := lblText.Top + lblText.Height + 10 + ArrowHeight;
if blnPosition = blnArrowTopRight then
ClientHeight := lblText.Top + lblText.Height + 10 + ArrowHeight;
if (lblTitle.Left + lblTitle.Width) > (lblText.Left + lblText.Width) then
Width := lblTitle.Left + lblTitle.Width + 10
else
Width := lblText.Left + lblText.Width + 10;
if blnPosition = blnArrowTopLeft then
begin
Left := blnLeft - (Width - 20);
Top := blnTop - (Height);
end;
if blnPosition = blnArrowTopRight then
begin
Left := blnLeft - 20;
Top := blnTop - (Height);
end;
if blnPosition = blnArrowBottomRight then
begin
Left := blnLeft - 20;
Top := blnTop - 2;
end;
if blnPosition = blnArrowBottomLeft then
begin
Left := blnLeft - (Width - 20);
Top := blnTop - 2;
end;
FormRegion := 0;
if blnPosition = blnArrowTopLeft then
begin
FormRegion := CreateRoundRectRgn(0, 0, Width, Height - (ArrowHeight - 2), 7, 7);
Arrow[0] := Point(Width - ArrowWidth - 20, Height - ArrowHeight);
Arrow[1] := Point(Width - 20, Height);
Arrow[2] := Point(Width - 20, Height - ArrowHeight);
end;
if blnPosition = blnArrowTopRight then
begin
FormRegion := CreateRoundRectRgn(0, 0, Width, Height - (ArrowHeight - 2), 7, 7);
Arrow[0] := Point(20, Height - ArrowHeight);
Arrow[1] := Point(20, Height);
Arrow[2] := Point(20 + ArrowWidth, Height - ArrowHeight);
end;
if blnPosition = blnArrowBottomRight then
begin
FormRegion := CreateRoundRectRgn(0, ArrowHeight + 2, Width, Height, 7, 7);
Arrow[0] := Point(20, 2);
Arrow[1] := Point(20, ArrowHeight + 2);
Arrow[2] := Point(20 + ArrowWidth, ArrowHeight + 2);
end;
if blnPosition = blnArrowBottomLeft then
begin
FormRegion := CreateRoundRectRgn(0, ArrowHeight + 2, Width, Height, 7, 7);
Arrow[0] := Point(Width - 20, 2);
Arrow[1] := Point(Width - 20, ArrowHeight + 2);
Arrow[2] := Point(Width - 20 - ArrowWidth, ArrowHeight + 2);
end;
ArrowRegion := CreatePolygonRgn(Arrow, 3, WINDING);
CombineRgn(FormRegion, FormRegion, ArrowRegion, RGN_OR);
DeleteObject(ArrowRegion);
SetWindowRgn(Handle, FormRegion, True);
Visible := False;
ShowWindow(Handle, SW_SHOWNOACTIVATE);
Visible := True;
tmrExit.Interval := blnDuration * 1000;
tmrExit.Enabled := True;
end;
end.
//------------------------
it has a property named Delay for specifying how long does it take for hint to disapear, or you can set it to zero for avoiding from disapearing the hint.
at last, I thank you again Slickers for your helps. the pings are yours.
mehdi_m