Custom HyperLink Gadget

[TI-994A]

Here's a custom hyperlink gadget which centres text, with options for colours and fonts, and should be cross-platform as well (tested on Windows & OSX only). As added effects, it also toggles colours when clicking, and changes cursor styles when hovering.

This is the required code framework:

Code: Select all

;==============================================================
;   HyperLink() extends the functions of HyperLinkGadget()
;   with text centering, colour-toggling when clicking,
;   and cursor-style-toggling when hovering. 
;   
;   Tested & working on Windows 8.1 & 10 and OSX Lion,
;   running PureBasic v5.50, v5.41, v5.40 respectively. 
;
;   by TI-994A - free to use, improve, share...
;
;   16th July 2016
;==============================================================

Structure HyperLinkData
  gNo.i
  text.s
  width.i
  height.i
  foreColour.i
  backColour.i
  hoverColour.i  
  fontID.i
EndStructure

Global Dim hld.HyperLinkData(0)

Procedure DrawHyperLink(*hld.HyperLinkData, state)
  With *hld
    StartDrawing(CanvasOutput(\gNo))
      DrawingMode(#PB_2DDrawing_Transparent)
      DrawingFont(\fontID)
      topMargin = (\height - TextHeight(\text)) / 2  
      leftMargin = (\width - TextWidth(\text)) / 2  
      Box(0, 0, \width, \height, \backColour)
      If state
        If state = 2
          DrawText(leftMargin, topMargin, \text, \foreColour)
        Else
          DrawText(leftMargin, topMargin, \text, \hoverColour)
        EndIf
      Else
        DrawText(leftMargin, topMargin, \text, \foreColour)
      EndIf
    StopDrawing()  
  EndWith
EndProcedure

Procedure HyperLinkProc()
  Protected gadgetNo = EventGadget()
  Protected *hld = GetGadgetData(gadgetNo)
  
  Select EventType()
    Case #PB_EventType_MouseEnter
      SetGadgetAttribute(gadgetNo, #PB_Canvas_Cursor, #PB_Cursor_Hand)
      DrawHyperLink(*hld, 1)
    Case #PB_EventType_MouseLeave
      SetGadgetAttribute(gadgetNo, #PB_Canvas_Cursor, #PB_Cursor_Default)
      DrawHyperLink(*hld, 0)
    Case #PB_EventType_LeftButtonDown            
      DrawHyperLink(*hld, 2)
    Case #PB_EventType_LeftButtonUp
      DrawHyperLink(*hld, 1)
  EndSelect
EndProcedure 

Procedure HyperLink(gadgetNo, x, y, width, height, text$, fColour, hColour, bColour, fontID = #PB_Ignore)
  Static defaultFont, gCount
  gCount + 1
  
  If gCount
    Dim prevGadgets(gCount - 1)
    For i = 1 To gCount - 1
      prevGadgets(i) = hld(i)\gNo
    Next i
    ReDim hld.HyperLinkData(gCount)
    For i = 1 To gCount - 1
      SetGadgetData(prevGadgets(i), @hld(i))
    Next i
  EndIf
  
  If gadgetNo = #PB_Any 
    gadgetNo = CanvasGadget(#PB_Any, x, y, width, height)
  Else
    CanvasGadget(gadgetNo, x, y, width, height)
  EndIf
  
  If fColour = #PB_Ignore : fColour = 16711680 : EndIf
  If hColour = #PB_Ignore : hColour = 255 : EndIf

  ;this sets the default background colour to white
  ;If bColour = #PB_Ignore : bColour = 16777215 : EndIf
  
  ;this sets the default background colour to the underlying window colour
  If bColour = #PB_Ignore
    StartDrawing(WindowOutput(GetActiveWindow()))
      bColour = Point(x + 10, y + 10)
    StopDrawing()
  EndIf
  
  If fontID = #PB_Ignore
    CompilerIf #PB_Compiler_OS = #PB_OS_MacOS
      If Not IsFont(defaultFont)
        defaultFont = LoadFont(#PB_Any, "Arial", 12)
      EndIf
      fontID = FontID(defaultFont)
    CompilerElse
      fontID = GetGadgetFont(#PB_Default)
    CompilerEndIf
  EndIf
  
  With hld(gCount)
    \gNo = gadgetNo
    \text = text$
    \width = width
    \height = height
    \foreColour = fColour
    \backColour = bColour
    \hoverColour = hColour
    \fontID = fontID
  EndWith
  
  DrawHyperLink(@hld(gCount), 0)
  SetGadgetData(gadgetNo, @hld(gCount))
  BindGadgetEvent(gadgetNo, @HyperLinkProc())
  ProcedureReturn gadgetNo
EndProcedure

And here's a demo to implement it:

Code: Select all

Enumeration
  #MainWindow
  #MyHyperLink
  #MyHyperLink2
  #Check1
  #Check2
  #Check3
  #Check4
EndEnumeration

#xRed = 255
#xGreen = 65280
#xBlue = 16711680
#xYellow = 65535
#xMagenta = 16711935
#xWhite = 16777215
#xGray = 16119285

wFlags = #PB_Window_SystemMenu | #PB_Window_ScreenCentered
OpenWindow(#MainWindow, #PB_Any, #PB_Any, 600, 400, "Custom HyperLinks", wFlags)
CheckBoxGadget(#Check1, 20, 50, 30, 20, "1")
CheckBoxGadget(#Check2, 20, 120, 30, 20, "2")
CheckBoxGadget(#Check3, 20, 200, 30, 20, "3")
CheckBoxGadget(#Check4, 20, 290, 30, 20, "4")
SetWindowColor(#MainWindow, #xWhite)

;with #PB_Any 
myHyperLink = HyperLink(#PB_Any, 210, 50, 180, 30, "Default Settings Hyperlink", #PB_Ignore, #PB_Ignore, #PB_Ignore)
myHyperLink2 = HyperLink(#PB_Any, 200, 120, 200, 30, "Custom Coloured Hyperlink", #xRed, #xGreen, #PB_Ignore)

;with constants
HyperLink(#MyHyperLink, 150, 200, 300, 40, "With Background Colour Hyperlink", #PB_Ignore, #PB_Ignore, #xYellow)

LoadFont(1, "Times New Roman", 14, #PB_Font_Italic)
HyperLink(#MyHyperLink2, 100, 290, 400, 40, "With Custom Font Hyperlink", #xWhite, #xMagenta, #xGreen, FontID(1))

Repeat
  Select WaitWindowEvent()
    Case #PB_Event_CloseWindow
      appQuit = 1
    Case #PB_Event_Gadget
      Select EventGadget()
        Case myHyperLink
          Select EventType()
            Case #PB_EventType_LeftClick
              SetGadgetState(#Check1, (GetGadgetState(#Check1)) ! 1)
          EndSelect
        Case myHyperLink2
          Select EventType()
            Case #PB_EventType_LeftClick
              SetGadgetState(#Check2, (GetGadgetState(#Check2)) ! 1)
          EndSelect
        Case #MyHyperLink
          Select EventType()
            Case #PB_EventType_LeftClick
              SetGadgetState(#Check3, (GetGadgetState(#Check3)) ! 1)
          EndSelect          
        Case #MyHyperLink2
          Select EventType()
            Case #PB_EventType_LeftClick
              SetGadgetState(#Check4, (GetGadgetState(#Check4)) ! 1)
          EndSelect          
      EndSelect
  EndSelect
Until appQuit = 1 

Feedback and suggestions are always welcome.

EDIT:The default background colour, in the HyperLink() procedure, was modified to sample the underlying window colour to simulate transparency. Not a very foolproof approach if the window is painted with a gradient or image, or if it is not the active window when the gadget is created.

[ts-soft]

Works fine on Linux! Thanks for sharing.

[mk-soft]

Nice, Thanks

[Andre]

Could become handy, thanks for sharing!

[Keya]

awesome work!!! great to have fine control over it
It doesnt currently seem to support transparent/default background though?
If you comment this line: SetWindowColor(#MainWindow, #xWhite)
the first two Default ones have white backgrounds instead of the default gray?

[TI-994A]

Thank you for saying so, guys. It's sincerely appreciated.

It doesnt currently seem to support transparent/default background though?

Yes; regrettably, it's not transparent. Although I believe that the HyperLinkGadget() isn't either.

A simple workaround would be to sample the underlying window colour with the Point() function. This is not a very elegant or foolproof solution, but it works.

Simply replace the default background setting in the HyperLink() procedure with this:

Code: Select all

  ;If bColour = #PB_Ignore : bColour = 16777215 : EndIf
  
  If bColour = #PB_Ignore
    StartDrawing(WindowOutput(GetActiveWindow()))
      bColour = Point(x + 10, y + 10)
    StopDrawing()
  EndIf

I've added this to the original code above, with the same remarks.

[davido]

@TI-994A,

Nice work.
Thank you for sharing.