Colored Balloon Tooltips with icons

[SoulReaper]

I had to detect with osversion() for it to work correct - I wonder if there is a bug... guess I am stumped on this one...

well I am running PB v4 beta 9 maybe its that

Regards
Kevin

[Rescator]

Seems to get the dreaded "invalid memory access" highlighting line 43 when I try to run/compile the last two sources shown here. hmm.
And with the debugger off the program crashes.
PB4 B9 btw, with the /beta/ file updates.

[Shannara]

Oooo.. I wasnt aware of beta updates Mine is just the download with no updates applied (PB4 Beta 9), This is with Windows XP Pro SP2, with all updates applied (to windows xp;)), and with themes turned off .. so it basically looks like Windows 2000 for the most part.

[Al_the_dutch]

Hi All,

After 10 years this post still has value...

But I'm facing a problem and need some help to solve it.

Code: Select all

; Problem: Tooltips for the StringGadget do not disappear if you go from bottom to top.
; No problem going down. No problem using ButtonGadgets as in the original Code.
; http://www.purebasic.fr/english/viewtopic.php?t=18805

; Using Win 10 x64 PureBasic 5.42LTS x86.

;OSversion
;
Global Osv.l

;-Gadget Id's 
; 
Global Win.l 
Global Btn1.l 
Global Btn2.l 
Global Btn3.l 
Global Btn4.l 

;-Declares 
; 
Declare ToolTip(Win, Id, style, Center, Icon, FgColor, BgColor, title.s, Tip.s, pOpacity.l) 
Declare OpenMainWindow() 

;-StartRun 
;

Osv.l = OSVersion() 
OpenMainWindow() 

;-Events 
; 
Repeat 
Until WaitWindowEvent() = #PB_Event_CloseWindow 

;-EndRun 
; 
End 

;-Procedures 
; 
Procedure SetWindowAlpha(hwnd.l, Opacity.l) 
   ;If Osv.l=#PB_OS_Windows_2000 Or Osv.l=#PB_OS_Windows_XP
   
    SetWindowLong_(hwnd, #GWL_EXSTYLE, GetWindowLong_(hwnd, #GWL_EXSTYLE) | $00080000) 
    If OpenLibrary(1, "user32.dll") 
      CallFunction(1, "SetLayeredWindowAttributes", hwnd, 0, Opacity, 2) 
      CloseLibrary(1) 
    EndIf 
  ;EndIf 
EndProcedure 

Procedure ToolTip(WinID, Id, style, Center, Icon , FgColor, BgColor, title.s, Tip.s, pOpacity.l) 
  ;Adds a tooltip to Id.  Style: 0 = ordinary, 1 = balloon. Center: 1 = center the stem 
  ;Icon: 0 = No icon, 1 = Info, 2 = Warn, 3 = Error, (See #TOOLTIP_ constants) 
  TT = CreateWindowEx_(0, "Tooltips_Class32", "", #TTS_BALLOON * style, 0, 0, 0, 0, 0, 0, 0, 0) 
  ;Color. RGB() or GetSysColor_(See #COLOR_ constants) 
  If FgColor 
    ;Set the tip text color, also the tip outline color for balloon tooltips 
    SendMessage_(TT, #TTM_SETTIPTEXTCOLOR, FgColor, 0) 
  EndIf 
  If BgColor 
    ;Set the tip background color 
    SendMessage_(TT, #TTM_SETTIPBKCOLOR, BgColor, 0) 
  EndIf 
  TI.ToolInfo\cbSize = SizeOf(ToolInfo) 
  TI\uFlags = #TTF_IDISHWND | #TTF_SUBCLASS |  (#TTF_CENTERTIP * Center) 
  TI\hwnd = WindowID(WinID) 
  TI\uId = GadgetID(Id) 
  TI\lpszText = @Tip 
  
  ;Set Opacity if any... 
  If pOpacity < 0 
    pOpacity = 100 
  ElseIf pOpacity > 100 
    pOpacity = 100 
  EndIf 
  
  If pOpacity < 100 
    pOpacity = Int ( pOpacity * 255 / 100 ) 
    SetWindowAlpha( TT, pOpacity ) 
  EndIf 
  
  ;Register tooltip with the control 
  SendMessage_(TT, #TTM_ADDTOOL, 0, TI) 
  ;Set as a multiline tooltip with wordwrap 
  SendMessage_(TT, #TTM_SETMAXTIPWIDTH, 0, 150) 
  ;Set the icon style and tip title 
  SendMessage_(TT, #TTM_SETTITLE, Icon, title) 
  
  ;Lets users give some more time to read the tooltip
  SendMessage_(TT,#TTM_SETDELAYTIME,#TTDT_INITIAL,0)
  SendMessage_(TT,#TTM_SETDELAYTIME,#TTDT_AUTOPOP,30000)  ;30000 is the highest value   
EndProcedure 

Procedure OpenMainWindow() 
  Win = OpenWindow(#PB_Any, 0, 0, 300, 300, "Tooltip Styles", #PB_Window_ScreenCentered|#PB_Window_SystemMenu) 
  If Win 
    If CreateGadgetList(WindowID(Win)) 
      
      ; Set opacity here... 
      lOpacity.l = 100
      
      Btn1 = StringGadget(#PB_Any, 110, 40, 80, 20, "String1") 
      ToolTip(Win, Btn1, 0, 0, 1, 0, 0, "", "This is a boring old Tooltip", lOpacity.l) 
      
      Btn2 = StringGadget(#PB_Any, 110,100, 80, 20, "String2") 
      ToolTip(Win, Btn2, 0, 1, 1, 0, RGB(226, 255, 255), "Title", "Not that boring old Tooltip", lOpacity.l) 
      
      Btn3 = StringGadget(#PB_Any, 110, 160, 80, 20, "String3") 
      ToolTip(Win, Btn3, 1, 0, 0, 0, RGB(226, 255, 255), "", "This is a multi line Tooltip This is a multi line Tooltip", lOpacity.l) 
      
      Btn4 = StringGadget(#PB_Any, 110, 220, 80, 20, "String4") 
      ToolTip(Win, Btn4, 1, 1, 1, RGB(57, 120, 63), RGB(226, 255, 255), "This is:", "A centered Tooltip", lOpacity.l) 
    EndIf 
  Else 
    End 
  EndIf 
EndProcedure

[mestnyi]

So like it dares not it?

Code: Select all

; Problem: Tooltips for the StringGadget do not disappear if you go from bottom to top.
; No problem going down. No problem using ButtonGadgets as in the original Code.
; http://www.purebasic.fr/english/viewtopic.php?t=18805

; Using Win 10 x64 PureBasic 5.42LTS x86.

;OSversion
;
Global Osv.l

;-Gadget Id's 
; 
Global Win.l 
Global Btn1.l 
Global Btn2.l 
Global Btn3.l 
Global Btn4.l 

;-Declares 
; 
Declare ToolTip(Win, ID, Style, Center, Icon, FgColor, BgColor, Title.s, Tip.s, pOpacity.l) 
Declare OpenMainWindow() 

;-StartRun 
;

Osv.l = OSVersion() 
OpenMainWindow() 

;-Events 
; 
Repeat 
Until WaitWindowEvent() = #PB_Event_CloseWindow 

;-EndRun 
; 
End 

;-Procedures 
; 
Procedure SetWindowAlpha(hwnd.l, Opacity.l) 
  ;If Osv.l=#PB_OS_Windows_2000 Or Osv.l=#PB_OS_Windows_XP
  
  SetWindowLong_(hwnd, #GWL_EXSTYLE, GetWindowLong_(hwnd, #GWL_EXSTYLE) | $00080000) 
  If OpenLibrary(1, "user32.dll") 
    CallFunction(1, "SetLayeredWindowAttributes", hwnd, 0, Opacity, 2) 
    CloseLibrary(1) 
  EndIf 
  ;EndIf 
EndProcedure 


Procedure IsMouseOverClient( hWnd )
  Protected Pt.Point
  Protected client.RECT 
  GetCursorPos_(Pt)    
  ScreenToClient_(hWnd, Pt) 
  GetClientRect_(hWnd, @client)
  If PtInRect_(@client,Pt\x | (Pt\y<<32))
    ProcedureReturn #True
  EndIf
EndProcedure
Procedure IsMouseOver(hwnd) ; Эта процедура определяет находится ли курсор мышки над заданым окном или гаджетом
  Protected Pt.Point
  Protected client.RECT 
  GetWindowRect_(hwnd,client.RECT) 
  GetCursorPos_(pt.Point) 
  Protected Result.l = PtInRect_(@client, pt\x | (pt\y<<32) )
  ProcedureReturn Result 
EndProcedure


Procedure IDProc(hWnd, uMsg, wParam, lParam)
  Protected sysProc = GetProp_( hWnd, "IDProc_CallBack") 
  
  If uMsg = #WM_MOUSEMOVE Or uMsg = #WM_MOUSELEAVE
    If IsMouseOverClient(hWnd) = 1
      ShowWindow_(GetProp_( hWnd, "IDProc_ID"),#SW_SHOWNOACTIVATE)
    Else
      ShowWindow_(GetProp_( hWnd, "IDProc_ID"),#SW_HIDE)
    EndIf
    
  EndIf
  
  ProcedureReturn CallWindowProc_(sysProc, hWnd, uMsg, wParam, lParam)
EndProcedure

Procedure ToolTip(WinID, ID, Style, Center, Icon , FgColor, BgColor, Title.s, Tip.s, pOpacity.l) 
  ;Adds a tooltip to Id.  Style: 0 = ordinary, 1 = balloon. Center: 1 = center the stem 
  ;Icon: 0 = No icon, 1 = Info, 2 = Warn, 3 = Error, (See #TOOLTIP_ constants) 
  TT = CreateWindowEx_(0, "Tooltips_Class32", "", #TTS_BALLOON * Style, 0, 0, 0, 0, 0, 0, 0, 0) 
  ;Color. RGB() or GetSysColor_(See #COLOR_ constants) 
  If FgColor 
    ;Set the tip text color, also the tip outline color for balloon tooltips 
    SendMessage_(TT, #TTM_SETTIPTEXTCOLOR, FgColor, 0) 
  EndIf 
  If BgColor 
    ;Set the tip background color 
    SendMessage_(TT, #TTM_SETTIPBKCOLOR, BgColor, 0) 
  EndIf 
  TI.ToolInfo\cbSize = SizeOf(ToolInfo) 
  TI\uFlags = #TTF_IDISHWND | #TTF_SUBCLASS |  (#TTF_CENTERTIP * Center) 
  TI\hwnd = WindowID(WinID) 
  TI\uId = GadgetID(ID) 
  TI\lpszText = @Tip 
  
  ;Set Opacity if any... 
  If pOpacity < 0 
    pOpacity = 100 
  ElseIf pOpacity > 100 
    pOpacity = 100 
  EndIf 
  
  If pOpacity < 100 
    pOpacity = Int ( pOpacity * 255 / 100 ) 
    SetWindowAlpha( TT, pOpacity ) 
  EndIf 
  
  ;Register tooltip with the control 
  SendMessage_(TT, #TTM_ADDTOOL, 0, TI) 
  ;Set as a multiline tooltip with wordwrap 
  SendMessage_(TT, #TTM_SETMAXTIPWIDTH, 0, 150) 
  ;Set the icon style and tip title 
  SendMessage_(TT, #TTM_SETTITLE, Icon, Title) 
  
  ;Lets users give some more time to read the tooltip
  SendMessage_(TT,#TTM_SETDELAYTIME,#TTDT_INITIAL,0)
  SendMessage_(TT,#TTM_SETDELAYTIME,#TTDT_AUTOPOP,30000)  ;30000 is the highest value   
  
  
  SetProp_( GadgetID(ID), "IDProc_ID", TT)
  SetProp_( GadgetID(ID), "IDProc_CallBack", SetWindowLong_(GadgetID(ID), #GWL_WNDPROC, @IDProc()))
EndProcedure 

Procedure OpenMainWindow() 
  Win = OpenWindow(#PB_Any, 0, 0, 300, 300, "Tooltip Styles", #PB_Window_ScreenCentered|#PB_Window_SystemMenu) 
  If Win 
    
    
    ; Set opacity here... 
    lOpacity.l = 100
    
    Btn1 = StringGadget(#PB_Any, 110, 40, 80, 20, "String1") 
    ToolTip(Win, Btn1, 0, 0, 1, 0, 0, "", "This is a boring old Tooltip", lOpacity.l) 
    
    Btn2 = StringGadget(#PB_Any, 110,100, 80, 20, "String2") 
    ToolTip(Win, Btn2, 0, 1, 1, 0, RGB(226, 255, 255), "Title", "Not that boring old Tooltip", lOpacity.l) 
    
    Btn3 = StringGadget(#PB_Any, 110, 160, 80, 20, "String3") 
    ToolTip(Win, Btn3, 1, 0, 0, 0, RGB(226, 255, 255), "", "This is a multi line Tooltip This is a multi line Tooltip", lOpacity.l) 
    
    Btn4 = StringGadget(#PB_Any, 110, 220, 80, 20, "String4") 
    ToolTip(Win, Btn4, 1, 1, 1, RGB(57, 120, 63), RGB(226, 255, 255), "This is:", "A centered Tooltip", lOpacity.l) 
    
  Else 
    End 
  EndIf 
EndProcedure

Although this could be solved with the following lines but it's stupid api.

Code: Select all

If uMsg = #WM_MOUSELEAVE
    DestroyWindow_( GetProp_( hWnd, "IDProc_ID") )
  EndIf
  

[Al_the_dutch]

Great! Thank you so much.