PureBasic Forums - English

Code: Select all

;/ Author : Andre / Balatro / Berikco

; ToolTipAdd
; Type : 0 = Balloon Tip / 1 Square Tip
; MaxWidth : Max Width of the ToolTip
; Icon : 0 (no Icon) / 1 (information icon) / 2 (warning icon) / 3 (error icon) 

ProcedureDLL ToolTipAdd(Type,MaxWidth,WindowID, Gadget, Text$ , Title$, Icon,TextColor,BKColor,Font.s,FontSize) 
  
  ;/ Initialise le Tableau au premier appel
  Static Initialised
  If Initialised=0
    Dim PtrToolTip(500)
    Initialised=1
  EndIf
  
  
  If Type=0 ;/ Ballon
    Type=#WS_POPUP | #TTS_NOPREFIX | #TTS_BALLOON
  Else      ;/ Or Square
    Type=#WS_POPUP | #TTS_NOPREFIX
  EndIf
  
  If TextColor=0 : TextColor=GetSysColor_(#COLOR_INFOTEXT) : EndIf
  If BKColor=0 : BKColor=GetSysColor_(#COLOR_INFOBK) : EndIf
  ToolTip=CreateWindowEx_(0,"ToolTips_Class32","",Type,0,0,0,0,WindowID(WindowID),0,GetModuleHandle_(0),0) 
  SendMessage_(ToolTip,#TTM_SETTIPTEXTCOLOR,TextColor,0) 
  SendMessage_(ToolTip,#TTM_SETTIPBKCOLOR,BKColor,0) 
  SendMessage_(ToolTip,#TTM_SETMAXTIPWIDTH,0,MaxWidth) 
  Balloon.TOOLINFO\cbSize=SizeOf(TOOLINFO) 
  Balloon\uFlags= #TTF_IDISHWND | #TTF_SUBCLASS
  Balloon\hWnd=WindowID(WindowID) 
  Balloon\uId=GadgetID(Gadget) 
  Balloon\lpszText=@Text$ 
  ;/ Fonts
  If Font>""
    LoadFont(#PB_Any, Font, FontSize); : UseFont(1) 
    SendMessage_(ToolTip, #WM_SETFONT, FontID(), #True) 
  EndIf
  
  SendMessage_(ToolTip, #TTM_ADDTOOL, 0, Balloon) 
  If Title$ > "" 
    SendMessage_(ToolTip, #TTM_SETTITLE, Icon, @Title$) 
  EndIf 
  PtrToolTip(Gadget)=ToolTip
EndProcedure 

ProcedureDLL ToolTipRemove(Gadget.l) 
  ttRemove.TOOLINFO\cbSize = SizeOf(TOOLINFO) 
  ttRemove\hWnd = WindowID() 
  ttRemove\uId = GadgetID(Gadget) 
  SendMessage_(PtrToolTip(Gadget), #TTM_DELTOOL, 0, ttRemove) 
EndProcedure 

ProcedureDLL ToolTipChange(Gadget.l, Text$) 
  ttChange.TOOLINFO\cbSize = SizeOf(TOOLINFO) 
  ttChange\hWnd = WindowID() 
  ttChange\uId = GadgetID(Gadget) 
  ttChange\lpszText = @Text$ 
  SendMessage_(PtrToolTip(Gadget), #TTM_UPDATETIPTEXT, 0, ttChange) 
EndProcedure 

ProcedureDLL ToolTipShow(Gadget.l,x,y)
  ttChange.TOOLINFO\cbSize = SizeOf(TOOLINFO) 
  ttChange\hWnd = WindowID() 
  ttChange\uId = GadgetID(Gadget)   
  SendMessage_(PtrToolTip(Gadget), #TTM_TRACKACTIVATE, 1, ttChange) 
  SetWindowPos_(PtrToolTip(Gadget), 0, x, y, -1, -1, #SWP_NOSIZE | #SWP_NOZORDER | #SWP_SHOWWINDOW | #SWP_NOACTIVATE) 
EndProcedure

ProcedureDLL ToolTipHide(Gadget.l)
  ttChange.TOOLINFO\cbSize = SizeOf(TOOLINFO) 
  ttChange\hWnd = WindowID() 
  ttChange\uId = GadgetID(Gadget)  
SendMessage_(PtrToolTip(Gadget), #TTM_TRACKACTIVATE, 0,ttChange) 

EndProcedure

;/
;/ LIBRARY TEST
;/

Procedure BackGroundTask()
  Repeat
    ToolTipChange(0,FormatDate("%hh:%ii:%ss", Date()))
    Delay(1000)
  ForEver
EndProcedure

OpenWindow(0,0,0,270,160,#PB_Window_SystemMenu|#PB_Window_ScreenCentered,"GadgetTooltip") 
CreateGadgetList(WindowID(0))
ButtonGadget(0,10,5,250,30,"Show/Hide ToolTip")
ButtonGadget(1,10,40,250,30,"Button 2")
ButtonGadget(2,10,75,250,30,"Button 3")
ButtonGadget(3,10,110,250,30,"Button 4")
ButtonGadget(4,0,0,0,0,"") ;/ Hidden Button
ToolTipAdd(0,200,0,0,"Tooltip n°1","ClockTip",0,RGB(255,255,0),RGB(255,0,0),"Comic sans ms",34)
ToolTipAdd(0,200,0,1,"This is a text","Tooltip n°2",3,0,0,"",0)
ToolTipAdd(0,200,0,2,"TOOLTIP 3"+#CRLF$+"MULTILINE"+#CR$+"    INPUT","",0,RGB(0,0,255),RGB(255,255,255),"impact",25)
ToolTipAdd(1,200,0,3,"This is a text","ToolTip n°4",1,RGB(100, 128, 128),RGB(128, 255, 128),"",0)
ToolTipAdd(1,300,0,4,"This is a multiline"+#CR$+"Tooltip and i can write"+#CR$+"what i want !","",0,0,65535,"Arial",12)

CreateThread(@BackGroundTask(),0)
Repeat
  temp=WaitWindowEvent()
  If temp=#PB_Event_Gadget And EventGadgetID()=0 And EventType()=#PB_EventType_LeftClick  
        Temp2=Not(Temp2)
        If Temp2
          ToolTipShow(4,512,384)
        Else
          ToolTipHide(4)
        EndIf
  EndIf
Until temp=#PB_Event_CloseWindow

Code: Select all

Dim PtrToolTip(500)