Another one - why the tooltip icon is that large?

[Michael Vogel]

Can anyone shrink the icon to a smaller size?

Code: Select all

Global Dim ToolTipHandle(1)
Procedure.l GadgetToolTipText_(Win,ID,Title.s,Tip.s,IconType)

	Protected ToolInfo.TOOLINFO

	If Len(Tip)=0
		Tip="(nicht definiert)"
	EndIf

	; Windows 8: runde Ecken bei "einzeiligen" Tips, allerdings bleibt das Verhalten völlig undurchschaubar...
	;If FindString(Tip,#CRLF$)=#Null
	;	Tip=" "+#CRLF$+Tip
	;EndIf

	ToolInfo\cbSize=SizeOf(TOOLINFO)
	ToolInfo\hwnd=WindowID(Win)
	ToolInfo\uId=GadgetID(ID)
	ToolInfo\lpszText=@Tip

	Debug "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
	Debug Str(Win)+" / "+Str(ID)+", "+Str(IconType)
	Debug Title+" / "+Tip
	Debug "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"

	SendMessage_(ToolTipHandle(ID),#TTM_SETTITLE, LoadIcon_(#Null,IconType),@Title)
	SendMessage_(ToolTipHandle(ID),#TTM_UPDATETIPTEXT,0,@ToolInfo)
	;SendMessage_(ToolTipHandle(ID),#TTM_UPDATE,0,@ToolInfo)

EndProcedure
Procedure.l GadgetToolTipInit_(Win,ID,Style,Center)

	; Adds a tooltip to a Gadget (Id)
	; Style:		0= ordinary, 1= balloon
	; Center:	1= center the stem
	; Icon:		0= No icon, 1= Info, 2= Warn, 3= Error (#TOOLTIP_ constants)
	; Colors:	RGB() or GetSysColor_(#COLOR_ constants)

	; Wegen Windows-Bug (Tooltip verschwindet nach Timeout auf ewig) nun global...
	Protected ToolTipID
	Protected ToolInfo.TOOLINFO

	ToolTipID=CreateWindowEx_(0,"Tooltips_Class32","",#TTS_NOPREFIX|#TTS_BALLOON*Style,0,0,0,0,0,0,0,0)

	;If FgColor
	;	SendMessage_(ToolTipID,#TTM_SETTIPTEXTCOLOR,FgColor,0);	Set the tip text color, also the tip outline color for balloon tooltips
	;EndIf
	;If BgColor
	;	SendMessage_(ToolTipID,#TTM_SETTIPBKCOLOR,BgColor,0);	Set the tip background color
	;EndIf

	ToolInfo\cbSize=SizeOf(TOOLINFO)
	ToolInfo\uFlags=#TTF_IDISHWND|#TTF_SUBCLASS|(#TTF_CENTERTIP*Center)
	ToolInfo\hWnd=WindowID(Win)
	ToolInfo\uId=GadgetID(ID)
	ToolInfo\lpszText=@"-"

	SendMessage_(ToolTipID,#TTM_SETDELAYTIME,#TTDT_INITIAL,100)
	;SendMessage_(ToolTipID,#TTM_SETDELAYTIME,#TTDT_RESHOW,1000); ?????
	SendMessage_(ToolTipID,#TTM_SETDELAYTIME,#TTDT_AUTOPOP,30000)

	SendMessage_(ToolTipID,#TTM_ADDTOOL,0,ToolInfo);		Register tooltip with the control
	SendMessage_(ToolTipID,#TTM_SETMAXTIPWIDTH,0,250);	Set as a multiline tooltip with wordwrap
	SendMessage_(ToolTipID,#TTM_SETTITLE,0,@"-");			Set the icon style and tip title

	ToolTipHandle(ID)=ToolTipID
	;Debug "Init "+Str(ID)+" ("+Str(ToolTipID)+")"

	ProcedureReturn ToolTipID

EndProcedure

OpenWindow(0,0,0,400,400,"*")
ButtonGadget(1,50,50,200,100,"HA")

GadgetToolTipInit_(0,1,0,0)

GadgetToolTipText_(0,1,"Ooohh","What a large icon :(",#IDI_WARNING);
Repeat
Until WaitWindowEvent()=#PB_Event_CloseWindow

[BarryG]

Can anyone shrink the icon to a smaller size?

I used Inf0Byt3's icon resize code from here: viewtopic.php?f=12&t=52966

And resized it to 16x16 like below. Don't forget you can always use your own smaller icons as an alternative, too.

Code: Select all

Procedure.i ResizeIcon(hIcon.i, Width.l, Height.l, Depth.l=32)
  Protected IInfo.ICONINFO, ColorImg.i, MaskImg.i, DC.i, RethIcon.i, ICONINFO.ICONINFO
  If hIcon <> 0
    ;Get icon data
    If GetIconInfo_(hIcon, @IInfo)
      Select Depth
        Case 24
          ColorImg = CreateImage(#PB_Any, Width, Height, 24)
        Default
          ColorImg = CreateImage(#PB_Any, Width, Height, 32)
      EndSelect
      If IsImage(ColorImg) <> 0
        ;Draw color image
        DC = StartDrawing(ImageOutput(ColorImg))
        If DC <> 0
          DrawIconEx_(DC,0,0,hIcon,Width,Height,0,0,#DI_IMAGE)
          StopDrawing()
        EndIf
      EndIf
      MaskImg = CreateImage(#PB_Any, Width, Height) ;Depth is 24 by default
      If IsImage(MaskImg) <> 0
        ;Draw mask
        DC = StartDrawing(ImageOutput(MaskImg))
        If DC <> 0
          DrawIconEx_(DC,0,0,hIcon,Width,Height,0,0,#DI_MASK)
          StopDrawing()
        EndIf
      EndIf
      ;Create new icon
      ICONINFO\fIcon = 1
      ICONINFO\hbmMask = ImageID(MaskImg)
      ICONINFO\hbmColor = ImageID(ColorImg)
      RethIcon = CreateIconIndirect_(@ICONINFO)
      ;And free the resources
      If IsImage(ColorImg)
        FreeImage(ColorImg)
      EndIf
      If IsImage(MaskImg)
        FreeImage(MaskImg)
      EndIf
      DeleteObject_(IInfo\hbmColor)
      DeleteObject_(IInfo\hbmMask)
    EndIf
  EndIf
  ProcedureReturn RethIcon
EndProcedure

Global Dim ToolTipHandle(1)
Procedure.l GadgetToolTipText_(Win,ID,Title.s,Tip.s,IconType)

   Protected ToolInfo.TOOLINFO

   If Len(Tip)=0
      Tip="(nicht definiert)"
   EndIf

   ; Windows 8: runde Ecken bei "einzeiligen" Tips, allerdings bleibt das Verhalten völlig undurchschaubar...
   ;If FindString(Tip,#CRLF$)=#Null
   ;   Tip=" "+#CRLF$+Tip
   ;EndIf

   ToolInfo\cbSize=SizeOf(TOOLINFO)
   ToolInfo\hwnd=WindowID(Win)
   ToolInfo\uId=GadgetID(ID)
   ToolInfo\lpszText=@Tip

   Debug "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
   Debug Str(Win)+" / "+Str(ID)+", "+Str(IconType)
   Debug Title+" / "+Tip
   Debug "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"

   icon=ResizeIcon(LoadIcon_(#Null,IconType),16,16,32)
   SendMessage_(ToolTipHandle(ID),#TTM_SETTITLE, icon,@Title)
   SendMessage_(ToolTipHandle(ID),#TTM_UPDATETIPTEXT,0,@ToolInfo)
   ;SendMessage_(ToolTipHandle(ID),#TTM_UPDATE,0,@ToolInfo)

EndProcedure
Procedure.l GadgetToolTipInit_(Win,ID,Style,Center)

   ; Adds a tooltip to a Gadget (Id)
   ; Style:      0= ordinary, 1= balloon
   ; Center:   1= center the stem
   ; Icon:      0= No icon, 1= Info, 2= Warn, 3= Error (#TOOLTIP_ constants)
   ; Colors:   RGB() or GetSysColor_(#COLOR_ constants)

   ; Wegen Windows-Bug (Tooltip verschwindet nach Timeout auf ewig) nun global...
   Protected ToolTipID
   Protected ToolInfo.TOOLINFO

   ToolTipID=CreateWindowEx_(0,"Tooltips_Class32","",#TTS_NOPREFIX|#TTS_BALLOON*Style,0,0,0,0,0,0,0,0)

   ;If FgColor
   ;   SendMessage_(ToolTipID,#TTM_SETTIPTEXTCOLOR,FgColor,0);   Set the tip text color, also the tip outline color for balloon tooltips
   ;EndIf
   ;If BgColor
   ;   SendMessage_(ToolTipID,#TTM_SETTIPBKCOLOR,BgColor,0);   Set the tip background color
   ;EndIf

   ToolInfo\cbSize=SizeOf(TOOLINFO)
   ToolInfo\uFlags=#TTF_IDISHWND|#TTF_SUBCLASS|(#TTF_CENTERTIP*Center)
   ToolInfo\hWnd=WindowID(Win)
   ToolInfo\uId=GadgetID(ID)
   ToolInfo\lpszText=@"-"

   SendMessage_(ToolTipID,#TTM_SETDELAYTIME,#TTDT_INITIAL,100)
   ;SendMessage_(ToolTipID,#TTM_SETDELAYTIME,#TTDT_RESHOW,1000); ?????
   SendMessage_(ToolTipID,#TTM_SETDELAYTIME,#TTDT_AUTOPOP,30000)

   SendMessage_(ToolTipID,#TTM_ADDTOOL,0,ToolInfo);      Register tooltip with the control
   SendMessage_(ToolTipID,#TTM_SETMAXTIPWIDTH,0,250);   Set as a multiline tooltip with wordwrap
   SendMessage_(ToolTipID,#TTM_SETTITLE,0,@"-");         Set the icon style and tip title

   ToolTipHandle(ID)=ToolTipID
   ;Debug "Init "+Str(ID)+" ("+Str(ToolTipID)+")"

   ProcedureReturn ToolTipID

EndProcedure

OpenWindow(0,0,0,400,400,"*")
ButtonGadget(1,50,50,200,100,"HA")

GadgetToolTipInit_(0,1,0,0)

GadgetToolTipText_(0,1,"Ooohh","What a large icon :(",#IDI_WARNING);
Repeat
Until WaitWindowEvent()=#PB_Event_CloseWindow

[RASHAD]

Hi BarryG
That is too much code to shrink the Icon

Code: Select all

SendMessage_(ToolTipHandle(ID),#TTM_SETTITLE, CopyImage_(LoadIcon_(#Null,IconType),#IMAGE_ICON,16,16,#LR_COPYDELETEORG	),@Title)

[Michael Vogel]

Perfect - as usual.
Thanks.

[IdeasVacuum]

Nice one Rashad!

[IdeasVacuum]

... by the way, I have never seen front and back colours working?

[BarryG]

That is too much code to shrink the Icon

Thanks for the single line, Rashad. I've been trying to adapt it for resizing non-icon images into a small icon, and can't. This fails:

Code: Select all

UsePNGImageDecoder()
big=LoadImage(0,"c:\picture.png")
small=CopyImage_(ImageID(0),#IMAGE_ICON,16,16,#LR_COPYDELETEORG)
Debug small ; Returns 0

[RASHAD]

Hi BarryG
You can not do that Bitmap is totally different from Icon

Code: Select all

UsePNGImageDecoder()
LoadImage(0,"c:\picture.png")

small=CopyImage_(ImageID(0),#IMAGE_BITMAP,16,16,#LR_COPYDELETEORG)

iinf.ICONINFO
iinf\fIcon = 1
iinf\hbmMask = small
iinf\hbmColor = small

icoHnd = CreateIconIndirect_(iinf)

[BarryG]

Thanks again, Rashad. It even supports transparent PNG images - cool!

[fryquez]

... by the way, I have never seen front and back colours working?

You need to disable theming for the tooltip window:

Code: Select all

SetWindowTheme_(ToolTipID, "", "")

[IdeasVacuum]

Thanks fryquez, that's a great tip for tooltips

[IdeasVacuum]

With this example code, we must have a ToolTipInit for every Tooltip.

Is there a specific reason why the two Procedures should not be one Procedure?

[IdeasVacuum]

.... I think the answer to my question is that the tip text buffer is unstable, but that seems to be fixed by ensuring the Tip Text is post-fixed with a newline (#CRLF$)

[BarryG]

Is there a specific reason why the two Procedures should not be one Procedure?

Do you mean for my example? The answer's easy: Michael wanted a smaller icon, so I just linked to some code that show hows to resize an icon. Then I just posted both procedures (the resize icon code, and Michael's original tooltip code) to show how it can be done. It's then up to the user to choose to merge them into one procedure if they wish.

But merging Rashad's single line into Michael's tooltip procedure would obviously be the superior solution.

[IdeasVacuum]

Hi BarryG - um no, I meant the original code posted by Michael. I have merged them into one Procedure and chopped-down to my requirements - balloon style, no icon, no title, no centre stem. I'm testing using the title for the tip text to get bold font.