Winapi tooltips
Windows winapi tooltips are a winapi product.The tooltip itself is a normal window created with API createWindow .
These are old things made by windows but are not very well implemented in vfp.Some simple rectangular tooltips come with vfp but never the balloon(the systray class is an exception).
this is a try to raise these controls and give a test for that.
the code creates windows constants.
see the photos below and the summary help in the big tooltip itself.
Some functionalities worked for me on win XP sp3 but dont work on win8.1 even win10 pro (backcolor+forecolor maybe or some themes reason).
select the code and copy with CTRL+C and paste into ytooltips.prg and run.
*Note : the picture used is downloaded automatically by code.
*Updated on 25 october 2016(style changed and no need to ytooltip.h)
Click on code to select [then copy] -click outside to deselect
Set Safe Off
Publi m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
*download the picture used in code.if dont have internet connect , replace by a local image named taghit_leksar de loin.jpg
Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName
Declare integer Sleep in kernel32 integer
Local lcDownloadURL,lcDownloadLoc,lnResult
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20150202/ob_f3c9b6_taghit-leksar-de-loin.JPG"
lcDownloadLoc = "taghit_leksar de loin.jpg"
lnResult = DeleteUrlCacheEntry(lcDownloadURL)
lnResult = URLDownloadToFile(0, lcDownloadURL, lcDownloadLoc , 0,0)
If lnResult = 0
Wait Window "Download taghit_leksar de loin.jpg Complete" nowait
*Else
*!* Messagebox("Download fails")
Endi
sleep(1000)
#DEFINE ICC_WIN95_CLASSES 0x000000FF
#DEFINE WM_CREATE 0x0001
#DEFINE WM_PARENTNOTIFY 0x0210
#DEFINE WM_PAINT 0x000F
#DEFINE WM_SHOWWINDOW 0x0018
#DEFINE WS_BORDER 0x800000
#DEFINE GWL_HINSTANCE -6
#DEFINE WM_USER 0x0400
#DEFINE TTM_ACTIVATE WM_USER +1
#DEFINE TTM_ADDTOOL WM_USER +4
#DEFINE TTM_ADDTOOLA WM_USER+4
#DEFINE TTM_DELTOOL (WM_USER + 5)
#DEFINE TTM_ADDTOOLW WM_USER+50
*#DEFINE TTDT_AUTOMATIC 0
*#DEFINE WS_EX_LAYERED 0x80000
*#DEFINE WS_EX_TRANSPARENT 0x00000020
#DEFINE TTS_NOFADE 0x20
#DEFINE TTS_NOANIMATE 0x10
#DEFINE TTM_SETTIPBKCOLOR WM_USER + 19
#DEFINE TTM_SETMAXTIPWIDTH WM_USER + 24
#DEFINE TTM_SETTIPTEXTCOLOR WM_USER + 20
#DEFINE TTM_SETTITLEA (WM_USER + 32)
#DEFINE TTM_UPDATETIPTEXTA (WM_USER + 12)
#DEFINE TTM_UPDATETIPTEXTW (WM_USER + 57)
#DEFINE TTM_ADJUSTRECT (WM_USER + 31)
#DEFINE WS_POPUP 0x80000000 &&added automatically if TTS_ALWAYSTIP
#DEFINE TOOLTIPS_CLASS "tooltips_class32"
#DEFINE CW_USEDEFAULT 0x80000000
#DEFINE TTM_TRACKACTIVATE WM_USER + 17
#DEFINE TTM_TRACKPOSITION WM_USER + 18
#DEFINE TTM_SETDELAYTIME WM_USER + 3
#DEFINE TTS_ALWAYSTIP 0x01
#DEFINE TTS_NOPREFIX 0x02
#DEFINE TTS_STANDARD 0
#DEFINE TTF_CENTERTIP 0x0002
#DEFINE TTF_SUBCLASS 0x0010
#DEFINE TTF_TRANSPARENT 0x0100
#DEFINE TTS_BALLOON 0x40
#DEFINE TTF_CENTERTIP 0x0002
#DEFINE TTF_SUBCLASS 0x0010
#DEFINE TTF_TRANSPARENT 0x0100
#DEFINE TTF_TRACK 0x0020
#DEFINE TTF_IDISHWND 0x0001
#DEFINE TTF_RTLREADING 0x0004
#DEFINE WS_EX_RTLREADING 0x00002000
#DEFINE WS_EX_LAYOUTRTL 0x00400000
*Places the window above all non-topmost windows. The window maintains its topmost position even when it is deactivated
#DEFINE HWND_TOPMOST -1
*#DEFINE HWND_TOP 0
#DEFINE WS_EX_TOPMOST 0x00000008
#DEFINE SWP_NOMOVE 0x2
#DEFINE SWP_NOSIZE 0x1
#DEFINE SWP_NOACTIVATE 0x10
#DEFINE TTF_PARSELINKS 0x1000 &&must be set with TTS_USEVISUALSTYLE
#DEFINE TTS_USEVISUALSTYLE 0x100
#DEFINE TTDT_AUTOPOP 2
#DEFINE POS_NONE 1
#DEFINE POS_ACTIVECTRL 2
#DEFINE POS_CARET 3
#DEFINE POS_SYS1270 4
#DEFINE POS_CTRLREF 5
#DEFINE CON_BIT_WS_BORDER 23
#DEFINE GWL_EXSTYLE -20
#DEFINE CON_BIT_TTS_CLOSE 7
#DEFINE TTS_CLOSE 0x80 &&make a close button on tooltip
#DEFINE SWP_NOZORDER 0x4
#DEFINE SWP_FRAMECHANGED 0x20
#DEFINE CON_BIT_WS_BORDER 23
#DEFINE GWL_EXSTYLE -20
#DEFINE GWL_STYLE -16
#DEFINE ANSI_CHARSET 0
#DEFINE OUT_OUTLINE_PRECIS 8
#DEFINE CLIP_STROKE_PRECIS 2
#DEFINE PROOF_QUALITY 2
#DEFINE DEFAULT_PITCH 0
#DEFINE WM_SETFONT 48
#DEFINE FW_NORMAL 400
#DEFINE FW_BOLD 700
#DEFINE GWL_WNDPROC -4
_Screen.addproperty("myvarP","") &&big tooltip text here
TEXT to _screen.myvarP textmerge noshow
This is a demo how to use the winapi tooltips.All is work with
winapi sendmessage and standard constants.
-It can embed large occidental text even unicode.
-can set the standard icon (0,1,2,3) or custom icon (16x16 or 32x32).
-can set the fontname,fontsize of the tooltip text.
-can make the tootip centered.It build itself its position.Its
simply a window created with the winapi createWindow.
-The backcolor and forecolor worked for me on WinXP sp3 but dont work
on win8.1.
-there is 3 tooltips type (balloon,standard (these 2 work on win8.1) and
rect no boder (this dont work on win8.1).can set a close button.
-Form.showtips property can enable tooltips or disable them.
-Many things stays yet not solved ......the best is yet to be!
ENDTEXT
Publi yform
yform=Newobject("ytooltips")
yform.Show
Read Events
*
Define Class ytooltips As Form
BorderStyle = 2
Top = 48
Left = 173
Height = 393
Width = 718
ShowWindow = 2
Caption = "Tooltip sample with APIs"
MaxButton = .F.
toolhwnd = 0
tooltip_backcolor = .F.
tooltip_forecolor = .F.
realhwnd = .F.
yicon = ".F."
yfontname = .F.
yfontstyle = .F.
yfontsize = .F.
Name = "YFORM"
Add Object shape2 As Shape With ;
Top = 24, ;
Left = 72, ;
Height = 217, ;
Width = 361, ;
BorderStyle = 0, ;
BackColor = Rgb(97,97,97), ;
Name = "Shape2"
Add Object command1 As CommandButton With ;
Top = 126, ;
Left = 580, ;
Height = 61, ;
Width = 135, ;
Caption = "Tooltip_BackColor (XP)", ;
BackColor = Rgb(128,255,0), ;
Name = "Command1"
Add Object command2 As CommandButton With ;
Top = 200, ;
Left = 580, ;
Height = 61, ;
Width = 135, ;
Caption = "Tooltip_Forecolor(XP)", ;
BackColor = Rgb(255,128,0), ;
Name = "Command2"
Add Object spinner1 As Spinner With ;
Height = 24, ;
Left = 600, ;
SpinnerHighValue = 3.00, ;
SpinnerLowValue = 0.00, ;
Top = 276, ;
Width = 73, ;
Value = 1, ;
Name = "Spinner1"
Add Object image1 As Image With ;
Picture = "taghit_leksar de loin.jpg", ;
Stretch = 2, ;
Height = 219, ;
Left = 61, ;
Top = 29, ;
Width = 366, ;
Name = "Image1"
Add Object check1 As Checkbox With ;
Top = 24, ;
Left = 600, ;
Height = 17, ;
Width = 62, ;
AutoSize = .T., ;
Alignment = 0, ;
BackStyle = 1, ;
forecolor=255,;
fontbold=.t.,;
Caption = "Tooltips", ;
Value = 1, ;
Name = "Check1"
Add Object optiongroup1 As OptionGroup With ;
AutoSize = .T., ;
ButtonCount = 3, ;
BackStyle = 0, ;
Value = 1, ;
Height = 65, ;
Left = 588, ;
Top = 49, ;
Width = 119, ;
Name = "Optiongroup1", ;
Option1.BackStyle = 0, ;
Option1.Caption = "Balloon", ;
Option1.Value = 1, ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Top = 5, ;
Option1.Width = 60, ;
Option1.AutoSize = .T., ;
Option1.Name = "Option1", ;
Option2.BackStyle = 0, ;
Option2.Caption = "Standard", ;
Option2.Height = 17, ;
Option2.Left = 5, ;
Option2.Top = 24, ;
Option2.Width = 68, ;
Option2.AutoSize = .T., ;
Option2.Name = "Option2", ;
Option3.BackStyle = 0, ;
Option3.Caption = "Rect No Borders", ;
Option3.Height = 17, ;
Option3.Left = 5, ;
Option3.Top = 43, ;
Option3.Width = 109, ;
Option3.AutoSize = .T., ;
Option3.Name = "Option3"
Add Object label1 As Label With ;
FontSize = 12, ;
BackStyle = 0, ;
Caption = "", ;
Height = 37, ;
Left = 24, ;
Top = 276, ;
Width = 157, ;
ForeColor = Rgb(128,0,64), ;
Name = "Label1"
Add Object command4 As CommandButton With ;
Top = 132, ;
Left = 480, ;
Height = 61, ;
Width = 97, ;
FontSize = 10, ;
WordWrap = .T., ;
Caption = "Custom icon 16x16 or 32x32", ;
Name = "Command4"
Add Object command5 As CommandButton With ;
Top = 24, ;
Left = 468, ;
Height = 49, ;
Width = 96, ;
Caption = "Set font Balloon", ;
Name = "Command5"
Add Object text1 As TextBox With ;
Value = "Arial,9,N", ;
ControlSource = "", ;
Height = 25, ;
Left = 12, ;
ReadOnly = .T., ;
Top = 360, ;
Width = 204, ;
Name = "Text1"
Add Object label2 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 16, ;
Alignment = 2, ;
Caption = "Unicode-Arabic", ;
Height = 27, ;
Left = 492, ;
MousePointer = 15, ;
Top = 336, ;
Width = 156, ;
BackColor = Rgb(128,255,255), ;
Name = "Label2"
Add Object check3 As Checkbox With ;
Top = 84, ;
Left = 468, ;
Height = 25, ;
Width = 109, ;
Alignment = 0, ;
Caption = "CenterTip", ;
Name = "Check3"
Add Object check5 As Checkbox With ;
Top = 252, ;
Left = 456, ;
Height = 17, ;
Width = 88, ;
AutoSize = .T., ;
Alignment = 0, ;
Caption = "Close button", ;
Value = 0, ;
Enabled = .T., ;
Name = "Check5"
Add Object shape1 As Shape With ;
Top = 264, ;
Left = 24, ;
Height = 49, ;
Width = 49, ;
BorderWidth = 3, ;
Curvature = 99, ;
MousePointer = 15, ;
BackColor = Rgb(0,255,0), ;
BorderColor = Rgb(255,0,0), ;
Name = "Shape1"
Procedure azup
Lparameters cBalloonTitle,cBalloonText, oControl ,yUnicode
If Thisform.check1.Value=0
Return .F.
Endi
If Empty(yUnicode) &&logical
yUnicode=.F.
Endi
Local cToolInfo, cText, ptrText, hHinstance, nError
If This.toolhwnd<> 0
WinAPI_DestroyWindow (This.toolhwnd)
This. toolhwnd = 0
Endif
If Empty (m.cBalloonText)
*Return .T.
Else
This.realhwnd = Iif(This.ShowWindow = 2, Sys(2327, Sys(2325, Sys(2326,This.HWnd))), This.HWnd)
m.hHinstance = WinAPI_GetWindowLong (This.toolhwnd , GWL_HINSTANCE)
Local zz
Do Case
Case This.optiongroup1.Value=1 &&BALLOON
If Thisform.check5.Value=0
zz=Bitor( TTS_ALWAYSTIP, TTS_NOPREFIX, TTS_BALLOON, TTS_USEVISUALSTYLE,WS_BORDER )
Else
zz=Bitor( TTS_ALWAYSTIP, TTS_NOPREFIX, TTS_BALLOON ,TTS_CLOSE,WS_BORDER,TTS_USEVISUALSTYLE )
Endi
This. toolhwnd = WinAPI_CreateWindow (;
0, TOOLTIPS_CLASS, "",;
m.zz ,;
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,;
this. realhwnd, 0, m.hHinstance, "" )
Case This.optiongroup1.Value=2
This. toolhwnd = WinAPI_CreateWindow (;
0, TOOLTIPS_CLASS, "",;
BITOR (WS_POPUP, TTS_ALWAYSTIP, TTS_NOPREFIX, TTS_STANDARD),;
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,;
this. realhwnd, 0, m.hHinstance, "" )
Case This.optiongroup1.Value=3 &&without border
This.toolhwnd = WinAPI_CreateWindow (;
0, TOOLTIPS_CLASS, "",;
BITOR (WS_POPUP, TTS_ALWAYSTIP, TTS_NOPREFIX, TTS_BALLOON),;
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,;
this. realhwnd, 0, m.hHinstance, "" )
m.dwStyle = Bitclear(m.hHinstance, CON_BIT_WS_BORDER)
WinAPI_SetWindowLong(This. toolhwnd, GWL_STYLE , m.dwStyle)
Endcase
If This. toolhwnd = 0
Return .F.
Endif
If yUnicode=.T.
zz= Bitor ( SWP_NOMOVE ,SWP_NOSIZE,SWP_NOACTIVATE,TTF_RTLREADING) &&rtl dont work
Else
zz= Bitor ( SWP_NOMOVE ,SWP_NOSIZE,SWP_NOACTIVATE)
Endi
WinAPI_SetWindowPos (;
this.toolhwnd,HWND_TOPMOST,;
Objtoclient (m.oControl, 2),;
Objtoclient (m.oControl, 1),;
0, 0,;
m.zz)
m.cText = Transform (m.cBalloonText) + Chr (0)
m.ptrText = WinAPI_HeapAlloc (WinAPI_GetProcessHeap (), 0, Len (m.cText))
If m.ptrText == 0
Return .F.
Endif
Sys (2600, ptrText, Len (cText), cText)
*return pointer as string -returns the string cText and also places nLen bytes of ctext at nAddress:
**********
Local yy
If Thisform.check3.Value=0
yy=BinToC(Bitor(TTF_TRANSPARENT, TTF_SUBCLASS),"4RS")
Else
yy=BinToC(Bitor(TTF_TRANSPARENT, TTF_CENTERTIP, TTF_SUBCLASS),"4RS")
Endi
m.cToolInfo =;
BinToC (11 * 4, "4RS") +; && cbSize 11 élements structure *4 bits chacune
m.yy +; && uFlags
BinToC (This.realhwnd, "4RS") +; && hWnd
BinToC (0, "4RS") +; && uId
BinToC (Objtoclient (m.oControl, 2), "4RS") +; && rect
BinToC (Objtoclient (m.oControl, 1), "4RS") +; && rect
BinToC (Objtoclient (m.oControl, 2) + Objtoclient (m.oControl, 3), "4RS") +; && rect
BinToC (Objtoclient (m.oControl, 1) + Objtoclient (m.oControl, 4), "4RS") +; && rect
BinToC (0, "4RS") +; && hInstance
BinToC (ptrText, "4RS") +; && uId
BinToC (0, "4RS") && lParam
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_ADDTOOL, 0, m.cToolInfo)
*Balloon font
If Empty(Thisform.yfontname) Or Thisform.yfontname="ARIAL"
Thisform.yfontname="ARIAL"
Thisform.yfontsize=12
Thisform.yfontstyle=""
Else
Local bold,italic,underline
m.bold=400
m.italic=0
m.underline=0
m.strikeout=0 &&used here
If "N" $ Thisform.yfontstyle
m.bold=400
m.italic=0
m.underline=0
m.strikeout=0
Endi
If "I" $ Thisform.yfontstyle
m.italic=1 &&0,1
Endi
If "B"$ Thisform.yfontstyle
m.bold=600 &&0-1000
Endi
Local xs
xs=Val(Thisform.yfontsize)
If xs<=12
xs=xs+5
Endi
hFont = WinAPI_CreateFont (m.xs, 0, 0,m.bold, 0, m.italic,m.underline,m.strikeout,;
ANSI_CHARSET, OUT_OUTLINE_PRECIS, CLIP_STROKE_PRECIS,;
PROOF_QUALITY, DEFAULT_PITCH, Thisform.yfontname)
hdc = GetWindowDC (This.toolhwnd)
m.nError = WinAPI_ToolAddSendMessage(This.toolhwnd, WM_SETFONT, hFont, 0)
* select new font into the device context and delete the old one
= DeleteObject (SelectObject (hdc, hFont))
Endi
m.nError= WinAPI_ToolAddSendMessage(This.toolhwnd, TTM_SETMAXTIPWIDTH, 0, 0) &&Set to multiline
#Define TTM_SETTITLEA (WM_USER + 32)
*standard icon
*TTIconNone = 0 && no icon
*TTIconInfo = 1 && i in white balloon
*TTIconWarning = 2 && ! in yellow triangle
*TTIconError = 3 && x in red circle
*or valid Icon loaded on thisform.yicon
m.nError= WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_SETTITLEA ,Thisform.yicon, m.cBalloonTitle) &&icon 0,1,2,3
*warning not all ico accepted 16x16 preference goes well-even all vista ico...
If Empty(Thisform.tooltip_backcolor)
Thisform.tooltip_backcolor=Rgb(255,255,193) &&Rgb(128,200,155)
Endi
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_SETTIPBKCOLOR,Thisform.tooltip_backcolor , 0)
If Empty(Thisform.tooltip_forecolor)
Thisform.tooltip_forecolor=0
Endi
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_SETTIPTEXTCOLOR, Thisform.tooltip_forecolor, 0)
If yUnicode=.F.
*#Define TTM_UPDATETIPTEXTA (WM_USER + 12)
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_UPDATETIPTEXTA, 0, m.cToolInfo)
Else
*#Define TTM_UPDATETIPTEXTW (WM_USER + 57)
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_UPDATETIPTEXTW , 0, m.cToolInfo)
Endi
* #Define TTM_ADJUSTRECT (WM_USER + 31)
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_ADJUSTRECT, 0, m.cToolInfo)
= WinAPI_HeapFree (WinAPI_GetProcessHeap (), 0, ptrText)
Return m.nError == 0
Endif
Retu
Endproc
Procedure bzup
Lparameters cBalloonTitle,cBalloonText, oControl ,yUnicode
*read from ytooltip.h all defined constants
If Thisform.check1.Value=0
Return .F.
Endi
If Empty(yUnicode) &&logical
yUnicode=.F.
Endi
Local cToolInfo, cText, ptrText, hHinstance, nError
If This.toolhwnd<> 0
WinAPI_DestroyWindow (This.toolhwnd)
This. toolhwnd = 0
Endif
If Empty (m.cBalloonText)
*Return .T.
Else
This.realhwnd = Iif(This.ShowWindow = 2, Sys(2327, Sys(2325, Sys(2326,This.HWnd))), This.HWnd)
m.hHinstance = WinAPI_GetWindowLong (This.toolhwnd , GWL_HINSTANCE)
Local zz
Do Case
Case This.optiongroup1.Value=1 &&BALLOON
If Thisform.check5.Value=0
zz=Bitor( TTS_ALWAYSTIP, TTS_NOPREFIX, TTS_BALLOON, TTS_USEVISUALSTYLE,WS_BORDER )
Else
zz=Bitor( TTS_ALWAYSTIP, TTS_NOPREFIX, TTS_BALLOON ,TTS_CLOSE,WS_BORDER,TTS_USEVISUALSTYLE )
Endi
This. toolhwnd = WinAPI_CreateWindow (;
0, TOOLTIPS_CLASS, "",;
m.zz ,;
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,;
this. realhwnd, 0, m.hHinstance, "" )
Case This.optiongroup1.Value=2
This. toolhwnd = WinAPI_CreateWindow (;
0, TOOLTIPS_CLASS, "",;
BITOR (WS_POPUP, TTS_ALWAYSTIP, TTS_NOPREFIX, TTS_STANDARD),;
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,;
this. realhwnd, 0, m.hHinstance, "" )
Case This.optiongroup1.Value=3 &&without border
This.toolhwnd = WinAPI_CreateWindow (;
0, TOOLTIPS_CLASS, "",;
BITOR (WS_POPUP, TTS_ALWAYSTIP, TTS_NOPREFIX, TTS_BALLOON),;
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,;
this. realhwnd, 0, m.hHinstance, "" )
m.dwStyle = Bitclear(m.hHinstance, CON_BIT_WS_BORDER)
WinAPI_SetWindowLong(This. toolhwnd, GWL_STYLE , m.dwStyle)
Endcase
If This. toolhwnd = 0
Return .F.
Endif
If yUnicode=.T.
zz= Bitor ( SWP_NOMOVE ,SWP_NOSIZE,SWP_NOACTIVATE,TTF_RTLREADING) &&rtl dont work
Else
zz= Bitor ( SWP_NOMOVE ,SWP_NOSIZE,SWP_NOACTIVATE)
Endi
WinAPI_SetWindowPos (;
this.toolhwnd,HWND_TOPMOST,;
Objtoclient (m.oControl, 2),;
Objtoclient (m.oControl, 1),;
0, 0,;
m.zz)
m.cText = Transform (m.cBalloonText) + Chr (0)
m.ptrText = WinAPI_HeapAlloc (WinAPI_GetProcessHeap (), 0, Len (m.cText))
If m.ptrText == 0
Return .F.
Endif
Sys (2600, ptrText, Len (cText), cText)
*return pointer as string -returns the string cText and also places nLen bytes of ctext at nAddress:
Local yy
If Thisform.check3.Value=0
yy=BinToC(Bitor(TTF_TRANSPARENT, TTF_SUBCLASS),"4RS")
Else
yy=BinToC(Bitor(TTF_TRANSPARENT, TTF_CENTERTIP, TTF_SUBCLASS),"4RS")
Endi
m.cToolInfo =;
BinToC (11 * 4, "4RS") +; && cbSize 11 élements structure *4 bits chacune
m.yy +; && uFlags
BinToC (This.realhwnd, "4RS") +; && hWnd
BinToC (0, "4RS") +; && uId
BinToC (Objtoclient (m.oControl, 2), "4RS") +; && rect
BinToC (Objtoclient (m.oControl, 1), "4RS") +; && rect
BinToC (Objtoclient (m.oControl, 2) + Objtoclient (m.oControl, 3), "4RS") +; && rect
BinToC (Objtoclient (m.oControl, 1) + Objtoclient (m.oControl, 4), "4RS") +; && rect
BinToC (0, "4RS") +; && hInstance
BinToC (ptrText, "4RS") +; && uId
BinToC (0, "4RS") && lParam
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_ADDTOOL, 0, m.cToolInfo)
*Balloon font
If Empty(Thisform.yfontname) Or Thisform.yfontname="ARIAL"
Thisform.yfontname="ARIAL"
Thisform.yfontsize=12
Thisform.yfontstyle=""
Else
Local bold,italic,underline
m.bold=400
m.italic=0
m.underline=0 &&1 npt used in font dialog
m.strikeout=0 && used here
If "N" $ Thisform.yfontstyle
m.bold=400
m.italic=0
m.underline=0
m.strikeout=0
Endi
If "I" $ Thisform.yfontstyle
m.italic=1 &&0,1
Endi
If "B"$ Thisform.yfontstyle
m.bold=600 &&0-1000
Endi
*if inlist("U",thisform.yfontstyle) && $ "U"
*m.underline=1 &&0,1 &&used 0
*endi
Local xs
xs=Val(Thisform.yfontsize)
If xs<=12
xs=xs+5
Endi
hFont = WinAPI_CreateFont (m.xs, 0, 0,m.bold, 0, m.italic,m.underline,m.strikeout,;
ANSI_CHARSET, OUT_OUTLINE_PRECIS, CLIP_STROKE_PRECIS,;
PROOF_QUALITY, DEFAULT_PITCH, Thisform.yfontname)
hdc = GetWindowDC (This.toolhwnd)
m.nError = WinAPI_ToolAddSendMessage(This.toolhwnd, WM_SETFONT, hFont, 0)
* select new font into the device context and delete the old one
= DeleteObject (SelectObject (hdc, hFont))
Endi
m.nError= WinAPI_ToolAddSendMessage(This.toolhwnd, TTM_SETMAXTIPWIDTH, 0, 0) &&Set to multiline
*
m.nError= WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_SETTITLEA ,Thisform.yicon, m.cBalloonTitle) &&icon 0,1,2,3
*warning not all ico accepted 16x16 preference goes well-even all vista ico...
If Empty(Thisform.tooltip_backcolor)
Thisform.tooltip_backcolor=Rgb(255,255,193) &&Rgb(128,200,155)
Endi
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_SETTIPBKCOLOR,Thisform.tooltip_backcolor , 0)
If Empty(Thisform.tooltip_forecolor)
Thisform.tooltip_forecolor=0
Endi
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_SETTIPTEXTCOLOR, Thisform.tooltip_forecolor, 0)
If yUnicode=.F.
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_UPDATETIPTEXTA, 0, m.cToolInfo)
Else
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_UPDATETIPTEXTW , 0, m.cToolInfo)
Endi
m.nError = WinAPI_ToolAddSendMessage (This.toolhwnd, TTM_ADJUSTRECT, 0, m.cToolInfo)
= WinAPI_HeapFree (WinAPI_GetProcessHeap (), 0, ptrText)
Return m.nError == 0
Endif
Retu
Endproc
Procedure Destroy
Set Safe On
Clea Dlls
Clea Events
Endproc
Procedure Init
Declare Integer InitCommonControlsEx In comctl32.Dll String
Declare Integer GetWindowLong In user32.Dll As WinAPI_GetWindowLong;
INTEGER HWnd, Integer nIndex
Declare Integer SetWindowLong In user32 As WinAPI_SetWindowLong ;
INTEGER HWnd,;
INTEGER nIndex,;
INTEGER dwNewLong
Declare Integer DestroyWindow In user32.Dll As WinAPI_DestroyWindow Integer
Declare Integer CreateWindowEx In user32.Dll As WinAPI_CreateWindow;
INTEGER, String, String, Integer, Integer, Integer,;
INTEGER, Integer, Integer, Integer, Integer, String
Declare Integer SendMessage In WIN32API As WinAPI_ToolAddSendMessage;
INTEGER, Integer, Integer, String
Declare Integer SetWindowPos In WIN32API As WinAPI_SetWindowPos;
INTEGER, Integer, Integer, Integer, Integer, Integer, Integer
Declare Integer GetProcessHeap In WIN32API As WinAPI_GetProcessHeap
Declare Integer HeapAlloc In WIN32API As WinAPI_HeapAlloc;
INTEGER, Integer, Integer
Declare Integer HeapFree In WIN32API As WinAPI_HeapFree;
INTEGER, Integer, Integer
Declare Integer CreateFont In gdi32 As winapi_createfont;
INTEGER nHeight, Integer nWidth, Integer nEscapement,;
INTEGER nOrientation, Integer fnWeight, Integer fdwItalic,;
INTEGER fdwUnderline, Integer fdwStrikeOut,;
INTEGER fdwCharSet, Integer fdwOutputPrecision,;
INTEGER fdwClipPrecision, Integer fdwQuality,;
INTEGER fdwPitchAndFamily, String lpszFace
Declare Integer ShellExecute In shell32 As winapi_shellexecute;
INTEGER HWnd,;
STRING lpOperation,;
STRING lpFile,;
STRING lpParameters,;
STRING lpDirectory,;
INTEGER nShowCmd
Declare Integer DeleteObject In gdi32 Integer hObject
Declare Integer GetWindowDC In user32 Integer HWnd
Declare Integer ReleaseDC In user32;
INTEGER HWnd, Integer hdc
Declare Integer SelectObject In gdi32;
INTEGER hdc, Integer hObject
* DECLARE INTEGER SetLayeredWindowAttributes IN user32;
INTEGER hwnd, INTEGER crKey,;
SHORT bAlpha, INTEGER dwFlags
******
Declare Integer CallWindowProc In User32 ;
PTR lpPrevWndFunc, API_HANDLE nhWnd, UINT uMsg, DD wParam, DD Lparam
Declare Integer GetClassName In User32 ;
API_HANDLE nhWnd, PSTR lpClassName, Integer nMaxCount
Declare Integer FindWindowEx In User32 ;
API_HANDLE hwndParent, API_HANDLE hwndChildAfter, ;
CSTR lpszClass, CSTR lpszWindow
#Define ICC_WIN95_CLASSES 0x000000FF
If InitCommonControlsEx (BinToC (8, "4RS") + BinToC (ICC_WIN95_CLASSES, "4RS")) == 0
Return .F.
Endif
Thisform.toolhwnd = 0
thisform.setall("mousepointer",15,"commandbutton")
This.Icon=Home(4)+[ICONS\MISC\MISC15.ICO] &&-----
Thisform.ShowTips=.T. &&mandatory to show the balloon
Thisform.check1.Value=Iif(Thisform.ShowTips=.T.,1,0)
This.realhwnd = Iif(This.ShowWindow = 2, Sys(2327, Sys(2325, Sys(2326,This.HWnd))), This.HWnd)
Endproc
Procedure command1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
Local myvar,cr
cr=Chr(13)+Chr(10)
myvar="Set the tooltip Backcolor here-you get a dialog box color."
Return Thisform.bzup("Tooltipcolor",m.myvar,This) &&SetTooltip(m.myvar,this)
Endproc
Procedure command1.Click
Local xcolor
xcolor=Getcolor()
If m.xcolor#-1
Thisform.tooltip_backcolor=m.xcolor
Endi
Endproc
Procedure command2.Click
Local xcolor
xcolor=Getcolor()
If m.xcolor#-1
Thisform.tooltip_forecolor=m.xcolor
Endi
Endproc
Procedure command2.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
Local myvar,cr
cr=Chr(13)+Chr(10)
myvar="Set the tooltip forecolor here.You get a dialog box colors"
Return Thisform.bzup ("",m.myvar,This)
Endproc
Procedure spinner1.Init
This.Value=1
Thisform.yicon=This.Value
Endproc
Procedure spinner1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
Local myvar,cr
cr=Chr(13)+Chr(10)
myvar="Set the tooltip icon here (0,1,2,3)"
*RETURN
Thisform.bzup("",m.myvar,This) &&----
* TTIconNone = 0 && none
* TTIconInfo = 1 && i in white balloon
* TTIconWarning = 2 && ! in yellow triangle
* TTIconError = 3 && x in red circle
Endproc
Procedure spinner1.InteractiveChange
Thisform.yicon=This.Value
Endproc
Procedure image1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
Return Thisform.bzup("Balloon title and icon",_screen.myvarP,This) &&,this,.f.,m.ylink)
Endproc
Procedure check1.InteractiveChange
Thisform.ShowTips=This.Value
Endproc
Procedure command4.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
Local myvar,cr
cr=Chr(13)+Chr(10)
myvar="Set the tooltip icon here-you get a dialog box "+cr+" Not all icons can work.Preferently choice 16x16 or 32x32 icons"
Return Thisform.bzup("",m.myvar,This)
Endproc
Procedure command4.Click
Local lcIcon
lcIcon=Getpict('ico')
If Empty(m.lcIcon) Or Lower(Justext(m.lcIcon))#"ico"
Return .F.
Endi
**custom icon
Try
loIcon = LoadPicture(m.lcIcon)
Declare Integer ExtractIcon In shell32 Integer hInst, String lpszExeFileName,;
INTEGER lpiIcon
Thisform.yicon=ExtractIcon (0,m.lcIcon,0)
Catch
Messagebox("Failed to load !",16)
Endtry
Endproc
Procedure command5.Click
Local xfont
xfont=Getfont()
If Not Empty(m.xfont)
Thisform.yfontname=Getwordnum(m.xfont,1,",")
Thisform.yfontsize=Getwordnum(m.xfont,2,",")
Thisform.yfontstyle=Getwordnum(m.xfont,3,",")
Endi
*messagebox(xfont)
Thisform.text1.Value=m.xfont
Retu
Endproc
Procedure label2.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
*this is an unicode arabic text converted with strconv(..,13) and restored with strconv(..,14) otherwise vfp dont support
local m.yun
text to m.yun noshow
//45BkUGRAZKBikGIAAnBkQGQgYxBjkGKQYgACMGSAYgACcGRAY6BkoGJwYoBiAAJwZEBkUGKgY5BkUGLwYgAEQGRAYsBicGRgYgACcGRAZFBi0GRAZKBikGDAYgAEUGJwYgACwGOQZEBiAAJwZEBjkGRQZEBkoGKQYgACcGRAYnBkYGKgYuBicGKAZKBikGIAAvBkgGRgYgADEGQgYnBigGKQYnACcALgANAAoAIABDBkUGJwYgAEQGJwYtBjgGIAAnBkQGKgZCBjEGSgYxBiAASAYsBkgGLwYgACcAJwBFBi0GJwY2BjEGIABBBjEGMgYgACcGRAYjBjUGSAYnBioGIABFBkUGNgYnBikGIAA5BkQGSQYgACgGSgYnBjYGIABFBkMGKgZIBigGKQYgACgGLQYoBjEGIAANAAoASAYnBi0GLwYgAEgGKAYuBjcGIABIBicGLQYvBiAASAYoBiUGRQY2BicGIQYnBioGIABFBjQGKAZIBkcGKQYnACcADQAKAC4AIABIBjMGLAZEBiAAJwAnACcGMwYqBjkGRQYnBkQGIABIBkMGJwZEBicGKgYgAEUGMgZIBjEGKQYMBiAASAYjBi0GSgYnBkYGJwYgAEUGRQY2BicGKQYgAEUGRgYgADcGMQZBBiAARQYzBiQGSAZEBkoGRgYgADMGJwYoBkIGSgZGBicAJwAuAA0ACgBIBi4GRAY1BioGIAAnBkQGRAYsBkYGKQYgACUGRAZJBiAALAZFBkQGKQYgAEUGRgYgACcGRAYqBkgGNQZKBicGKgYMBiAAIwYoBjEGMgZHBicGIAAnAA0ACgAnACoGNAZDBkoGRAYgAEcGSgYmBikGIABFBjMGKgZCBkQGKQYgAEUGLgYqBkQGNwYpBiAASAYnBi0GLwYpBiAAQQZCBjcGIABEBkQGJQY0BjEGJwZBBiAASAYnBkQGRQYxBicGQgYoBikGIABIBioGRgY4BkoGRQYgAA0ACgAnBkQGOQZFBkQGSgYpBiAAJwZEBicGRgYqBi4GJwYoBkoGKQYgAEgGJQY5BjcGJwYmBkcGJwYgAEMGRAYgACcGRAY1BkQGJwYtBkoGJwYqBgwGIABIBicGMwYqBi8GOQYnBiEGIAAnBkQGIwYtBjIGJwYoBiAARQZGBiAANwYxBkEGIAAnBkQGLQZDBkgGRQYpBiAARAZEBkUGNAYnBkgGMQYnBioGDQAKACAAQgYoBkQGIAAnBkQGOQZFBkQGSgYpBiAAJwZEBicGRgYqBi4GJwYoBkoGKQYMBiAASAYnBjMGKgY5BkUGJwZEBiAAJwZEBkgGMQZCBikGIAAnBkQGSAYnBi0GLwYpBiAARAYsBkUGSgY5BiAAJwZEBkIGSAYnBiYGRQYMBiAASAYnBkQGMwZFBicGLQYgAEQGRAYjBi0GMgYnBigGIAAnBkQGMwZKBicGMwZKBikGDQAKACAAKAYnBkQGJwY3BkQGJwY5BiAAOQZEBkkGIAAnBkQGQgYnBiYGRQYpBiAAJwZEBicGRgYqBi4GJwYoBkoGKQYgACgGSAZCBioGIABDBicGQQYMBiAASAYqBjEGKgZKBigGIAAnBkQGRwZKBiYGKQYgACcGRAZGBicGLgYoBikGIABIBioGQgYvBkoGRQZHBicGIABIBkEGQgYgAEIGMQY1BiAARQY2BjoGSAY3BiAADQAKAEIGJwYoBkQGIABEBkQGJwYzBioGOgZEBicGRAYMBiAASAYvBjEGJwYzBikGIABFBkQGQQYgACcGRAYqBjEGNAYtBiAASgZDBkgGRgYgAEUGRgYgADcGMQZBBiAAJwZEBiUGLwYnBjEGKQYgACgGRQY0BicGMQZDBikGIAAnBkQGIwYtBjIGJwYoBiAASAYnBkQGOQYvBicGRAYpBgwGIABIBicGRAYqBjUGSAZKBioGDQAKACAAKAYnBkQGSAZDBicGRAYpBiAARAZEBiMGMwZEBicGQwYgACcGRAZGBjgGJwZFBkoGKQYgAEEGSgYgACgGRAYvBkoGJwYqBkcGRQYgACcGRAYjBjUGRAZKBikGLgA=
endtext
Local m.myvar
m.myvar=strconv(m.yun,14) +chr(0) &&Filetostr("yUnicode.txt")+Chr(0&
Thisform.bzup("Balloon unicode text-Arabic here",m.myvar,This,.T.) &&pb alignment RTl
Endproc
Procedure check3.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
Local myvar,cr
cr=Chr(13)+Chr(10)
myvar="Make the tooltip centered at the control or at the mouse position"
Return Thisform.azup("Tooltiption",m.myvar,This) &&SetTooltip(m.myvar,this)
Endproc
Procedure shape1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
Return Thisform.bzup ("Author: B.Yousfi 08/02/2013",_screen.myvarP,This)
Endproc
Enddefine
this photo (Taghit_leksar de loin.jpg) is used in the code .Can download it in the source folder.
This is some screenshots of the application in action.
Warnings:
3 Problems encountered with copying code by selection (even i corrected but the same pb subsists on rendered page from the provider editor)-if you refresh the page (f5) it seems correct and the pb re come!
This.Icon=Home(4)+"ICONS\MISC\MISC15.ICO ---add a " coma at end
Thisform.bzup("",m.myvar,This add )...... at end----
Return Thisform.bzup("",m.myvar,This add )....... at end----