Winapi tooltips

Published on by Yousfi Benameur


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 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.
This is some screenshots of the application in action.
This is some screenshots of the application in action.
This is some screenshots of the application in action.
This is some screenshots of the application in action.

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----

 

Published on Visual foxpro, WIINAPI, TOOLTIPS

To be informed of the latest articles, subscribe:
Comment on this post
J
Thank You very much, I was looking for this for long time...
Reply
V
Very impressive !
Reply
Y
Thank you !