//========================================================================================
//  DNS Technology
//
//  FileName     : TOOLTIP.000
//  Author       : S G Munn    (sgmunn@compuserve.com)
//  Date Created : 01/10/1997
//  Version      : 1.0
//
//  Purpose      : Tooltip controller
//========================================================================================
//  Parameters   : none
//               :
//  Interface    :
//               :
//========================================================================================
//  Usage        : Use tooltip.000 just before the end_object statement of the 'main'
//               : object.
//               :
//               : Also, I have had problems with timers if the dftimer package is used
//               : inside the 'main' object.  I use dftimer outside main (just after the
//               : 'use dfallent').
//               :
//               :
//               :
//               :
//               :     use tooltip.000
//               : end_object // main
//               :
//               : for any object you want a tool tip for, define the following in the
//               : object (or class definition)
//               :
//               : function TooltipHint returns string
//               :     function_return "tool tip string" // or property, or expression etc.
//               : end_function
//               :
//               : <Optional>
//               : function TooltipHintObject returns integer
//               :     function_return Object_ID_Of_Alternate_Tool_Tip_Object
//               : end_function
//               :
//========================================================================================
//  History      :
//    Task Id    : none
//    Author     : SGM
//    Date       : 21/10/1997
//    Comments   : Added ability for tool tip timer to 'see' the window handle of objects
//               : within a modal panel.
//               :
//    Task Id    : none
//    Author     : SGM
//    Date       : 15/12/1997
//    Comments   : Fixed bug with getting size and location of panel (it was offset by the
//               : panel's caption bar).
//               : Removed function requirement to test if object should show a tool tip -
//               : return a null tool tip string for no tool tip.
//               : Added ability for object to specify a different tool tip object other
//               : than the default 'windows like' tool tip.
//               : The parent object of this PKG does not have to 'main'.  But the PKG
//               : should still be used at the end of the object.
//               : Uses PlusPak!'s cTimer class.  This can be changed to use DFTimer
//               : by changing the compiler directive TOOLTIP_USE_PLUSPAK_CTIMER to NO
//               :
//               :
//    Task Id    : none
//    Author     : SGM
//    Date       : 15/06/1998
//    Comments   : Changed name type POINT to TOOLTIP_POINT to avoid compile problemns
//               : with pkg's that define a point type as well.
//               :
//               :
//               :
//               : TODO.
//               : 1. Remove tool tip when mouse is clicked.
//               : 2. Allow the 'use tooltip.000' to be anywhere.
//               :
//               :
//               :
//               :
//               :
//               :
//               :
//========================================================================================
// Updated By    : Oliver T. Nelson, Hallmark Insurance, Fresno, CA
// Update Date   : 04/06/1999
// Comments      : Basically changed S G Munn's stuff to support multiline tooltips.  They
//               : are automatically wrapped on word nearest 40 chars per line.  Seems to
//               : OK, although the method I use is a little flaky.
use Windows
use cTimer         // PlusPak! timer control

Register_object ToolTipTimer000

integer TooltipControllerID     // the object id of the tool tip timer
integer DefaultTooltipHintID    // the object id of the default tool tip object

// Point type
type TOOLTIP_POINT
    field TOOLTIP_POINT.X as dword
    field TOOLTIP_POINT.Y as dword
end_type

// API call to return the position of the mouse
#IFNDEF GET_GETCURSORPOS
  External_Function GetCursorPos "GetCursorPos" user32.dll pointer lppt returns integer
#ENDIF

// API call to return the active window associcated with the calling thread (ie DFRUN)
#IFNDEF GET_GETACTIVEWINDOW
  External_Function GetActiveWindow "GetActiveWindow" user32.dll returns integer
#ENDIF

// default function for objects, returns the hint string of an object
function TooltipHint for DFObject returns string
    Function_Return ""
end_function

// default function for objects, returns the hint object of an object
function TooltipHintObject for DFObject returns string
    function_return DefaultTooltipHintID
end_function

// SGM : 21/10/1997
// this is a hook for us to get the window handle of a dfpanel class object.
// this will either be the 'main' window handle, or a dialog's window handle.
function WindowHandleForToolTip for DFPanel returns integer
    integer hd
    get Window_Handle to hd
    function_return hd
end_function

// returns the DF object id that is currently under the mouse.
// the 'side effect' of this is that it will return the df object id of
// ANY df object (even ones in a different VDF program!)
function GetDFObjectUnderMouse global returns integer
    string  pnt    //  a TOOLTIP_POINT type
    pointer pPnt   //  a pointer to a TOOLTIP_POINT type
    integer xx     //  x location
    integer yy     //  y location
    handle  hd     //  handle of window under mouse
    integer iObj   //  the DF object under the mouse location

    filltype TOOLTIP_POINT with 0 to pnt

    GetAddress of pnt to pPnt

    move (GetCursorPos(pPnt)) to windowindex

    getbuff from pnt at TOOLTIP_POINT.X to xx
    getbuff from pnt at TOOLTIP_POINT.Y to yy

    move (WindowFromPoint(xx,yy)) to hd

    Get_Object_From_Window hd to iObj

    function_return iObj
end_function


class ToolTipLine is a form
    procedure construct_object
        integer iExt
        forward send construct_object
        set form_border to border_none
        get text_extent "Any Text" to iExt
        set GuiSize to (hi(iExt)) 0
        Set Color     to clInfoBk
        Set TextColor to clInfoText
        set focus_mode to nonfocusable
    end_procedure
end_class

// this class replaces S G Munn's StandardToolTipLabel000 that was based on a textbox.  I tried using an edit,
// but the edit class is buggy and the horizontal scroll bar is hard to get rid of.  I tried a grid, but I had
// an invalid item reference problem that I finally gave up on tracking down.  Then I came upon the idea of
// using form objects, but they need to have a container so that I wouldn't have to completely rewrite S G
// Munn's code.  Hence the Container3d class! - OLIVER
class StandardToolTipLabel000 is a Container3d
    procedure Construct_Object
        forward send Construct_Object

        property string sTipUnformatted  // so that it can be cross checked with its passed value
                                         // to see if there have been any changes to the text.
        //1999-04-10 ------------------------------------ Start Nils G. Svedmyr
        set Border_Style to Border_None //Border_Normal    // this gives the single blank line that I'm looking for - OLIVER
        Set Color     to clInfoBk
        Set TextColor to clInfoText
        //1999-04-10 ------------------------------------ Stop Nils G. Svedmyr

        object Line_Array is an Array
        end_object

        // I had to create the objects here because if I dynamically created them, they would
        // not get displayed in the toolpanel.  I don't know why this was so,  the objects were
        // being created, they just wouldn't display no matter what I did :-(
        // Why 7??  Because I wanted 7!! - OLIVER
        object ToolTipLine000 is a ToolTipLine
            move self to windowindex
            set value of line_array item 0 to windowindex
        end_object
        object ToolTipLine001 is a ToolTipLine
            move self to windowindex
            set value of line_array item 1 to windowindex
        end_object
        object ToolTipLine002 is a ToolTipLine
            move self to windowindex
            set value of line_array item 2 to windowindex
        end_object
        object ToolTipLine003 is a ToolTipLine
            move self to windowindex
            set value of line_array item 3 to windowindex
        end_object
        object ToolTipLine004 is a ToolTipLine
            move self to windowindex
            set value of line_array item 4 to windowindex
        end_object
        object ToolTipLine005 is a ToolTipLine
            move self to windowindex
            set value of line_array item 5 to windowindex
        end_object
        object ToolTipLine006 is a ToolTipLine
            move self to windowindex
            set value of line_array item 6 to windowindex
        end_object
    end_procedure

    procedure Auto_size String Val Integer iLineCount
        integer ext

        get Text_Extent Val to ext

        // some hard coded sizes, works though
        set Guisize to ((hi(Ext) * iLineCount) + 8) (low(Ext))
        send Adjust_logicals
    end_procedure

    procedure Add_TipLine String sTmp Integer iLine# Integer iTxtExtent
        integer iObj
        get integer_value of line_array item iLine# to iObj
        //1999-04-10 ------------------------------------ Start Nils G. Svedmyr
        //        set GuiSize of iObj to (hi(iTxtExtent)) (low(iTxtExtent))
        // This is needed to display ��� correct.
        set GuiSize of iObj to (hi(iTxtExtent) + 2) (low(iTxtExtent) + 5)
        //1999-04-10 ------------------------------------ Stop Nils G. Svedmyr
        set Guilocation of iObj to ((iLine# * (hi(iTxtExtent))) + 1) 0  // the +1 adds a little space at the top of the tooltip
        set value of iObj to sTmp
        if (iLine# < 7) begin
            repeat
                increment iLine#
                get integer_value of line_array item iLine# to iObj
                set value of iObj to ""
            until (iLine# >= 6)
        end
    end_procedure

    procedure UpdateTip string sTip
        string misc LongestLine tmp tmpchr
        integer iCnt iLntoGet iLen iLngTxtExt iTxtExt
        set sTipUnformatted to sTip
        Move (Trim(sTip))   to sTip

        // I chose 40 as the length of a line because I think
        // it looked good at this size.  I could easily be changed
        // and should probably be a property. - OLIVER
        if (length(sTip) > 40) begin
            Move 60 to iLntoGet // 40

            repeat
                Move (Length(sTip)) to iLen
                if (iLen > 60) begin // 40
                    Move 60 to iLntoGet // 40

                    // this loop is for word wrapping.  It is really very primitive!  It
                    // should have a little more intelligence, but in most cases it works,
                    // and if it doesn't I can adjust my text to make it fit! - OLIVER
                    repeat
                        mid sTip to tmpChr 1 iLntoGet
                        if (tmpChr <> ' ') decrement iLntoGet
                    until (tmpChr = ' ' or iLntoGet <= 0)

                end
                else move iLen to iLntoGet

                left sTip to misc iLntoGet

//                move "  " to tmp       // pad both sides with spaces
//                append tmp misc "  "   // for a 'border'
                Move (" " + String(misc) + " ") to tmp

                get Text_Extent tmp to iTxtExt

                send add_tipLine tmp iCnt iTxtExt

                if (iTxtExt > iLngTxtExt) begin
                    move iTxtExt to iLngTxtExt
                    move tmp to LongestLine
                end

                right sTip to sTip (iLen - iLntoGet)
                increment iCnt
            until (length(sTip) <= 0 or iCnt >= 6)
        end
        else if (sTip <> "") begin
            move "  " to tmp
            append tmp (trim(sTip)) "  "
            get Text_Extent tmp to iTxtExt

            send Add_TipLine tmp 0 iTxtExt

            move tmp to LongestLine
            move 1 to iCnt
        end
        send Auto_size LongestLine iCnt
    end_procedure

end_class

//========================================================================================
//  Name         : StandardToolTip000
//  Purpose      : The standard tool tip class, looks like the normal windows one.
//========================================================================================
class StandardToolTip000 is a ToolPanel

    //====================================================================================
    //  Name         :
    //  Scope        : PRIVATE
    //  Purpose      :
    //====================================================================================

    //====================================================================================
    //  Name         : Construct_Object
    //  Scope        : PRIVATE
    //  Purpose      : Augmentation
    //====================================================================================
    procedure Construct_Object
        forward send Construct_Object
        set Border_Style  to BORDER_NORMAL
        set Caption_Bar   to false
        set Visible_State to false
        set Color to clInfoBk

        // our 'text label' for the tool tip.
        object ToolTipLabel is a StandardToolTipLabel000
            //1999-04-10 ------------------------------------ Start Nils G. Svedmyr
//            set Location     to -1 -2
            // Needed to display ��� correct.
            set Location     to 0 -2
            //1999-04-10 ------------------------------------ Stop Nils G. Svedmyr
        end_object
    end_procedure

    //====================================================================================
    //  Name         : LocateToolTip
    //  Scope        : PRIVATE
    //  Purpose      : locate the tip just below the mouse (at least off the hot spot)
    //====================================================================================
    procedure LocateToolTip
        string  pnt    //  a TOOLTIP_POINT type
        pointer pPnt   //  a pointer to a TOOLTIP_POINT type
        integer xx     //  x location
        integer yy     //  y location

        filltype TOOLTIP_POINT with 0 to pnt

        GetAddress of pnt to pPnt

        move (GetCursorPos(pPnt)) to windowindex

        getbuff from pnt at TOOLTIP_POINT.X to xx
        getbuff from pnt at TOOLTIP_POINT.Y to yy

        // a bit of hard coding, but what the hell
        set GUILocation to (yy + 20) xx
    end_procedure

    //====================================================================================
    //  Name         : ShowToolTip
    //  Scope        : PRIVATE
    //  Purpose      : Show the requested tool tip
    //====================================================================================
    procedure ShowToolTip string sTip
        integer sz

        // don't do anything, if it is visible AND has the same value!
        if (Visible_State(Self)) begin
            // we are already visible, so determine if we need to do anything
            if (sTipUnformatted(ToolTipLabel(Self)) = sTip) begin
                // we are already showing this one,
                procedure_return
            end
        end
        send UpdateTip of (ToolTipLabel(self)) sTip

        get Size  of (ToolTipLabel(self)) to sz
        //set Size to ((hi(sz)) + 2) ((low(sz)) + 4)
        set Size to ((hi(sz)) - 2) ((low(sz)) - 2)
        send LocateToolTip
        set Visible_State to true
    end_procedure

    //====================================================================================
    //  Name         : HideToolTip
    //  Scope        : PRIVATE
    //  Purpose      : get rid of the tool tip
    //====================================================================================
    procedure HideToolTip
        set Visible_State to false
        send UpdateTip to (ToolTipLabel(current_object)) ""
        set Location      to -100 -100
    end_procedure
end_class

//========================================================================================
//  Name         : ToolTipTimer000
//  Purpose      : Class of object to control the tool tips.  Timer turns them on and off.
//========================================================================================
    class ToolTipTimer000 is a cTimer

    //====================================================================================
    //  Name         :
    //  Scope        : PRIVATE
    //  Purpose      :
    //====================================================================================

    //====================================================================================
    //  Name         : Construct_Object
    //  Scope        : PRIVATE
    //  Purpose      : Augmentation
    //====================================================================================
    procedure Construct_Object
        Boolean bToolTip
        forward send Construct_Object
        // 2002-11-25 ------------------------------------ Start Nils G. Svedmyr
        Get ReadDWord Of ghoApplication "Preferences" "pbToolTip" 0 To bToolTip
        // 2002-11-25 ------------------------------------ Stop Nils G. Svedmyr

        property integer ToolTipVisible    false  // are we displaying the tool tip
        property integer LastToolTipObject 0      // what was the last tool tip obj
        // 2001-10-16 ------------------------------------ Start Nils G. Svedmyr
        Property Boolean pbTooltip bToolTip
        // 2001-10-16 ------------------------------------ Stop Nils G. Svedmyr
    end_procedure

    //====================================================================================
    //  Name         : ShowToolTip
    //  Scope        : PRIVATE
    //  Purpose      : Show the requested tool tip
    //====================================================================================
    procedure ShowToolTip integer ToolTipObject string sTip
        integer currentTipObj

        get LastToolTipObject to currentTipObj
        if (ToolTipObject <> currentTipObj) begin
            // the tool tip we want to use is different to the one we used last
            // so turn it off
            if (ToolTipVisible(self)) send HideToolTip
        end

        if (ToolTipObject <> 0) begin
            set LastToolTipObject to ToolTipObject
            set ToolTipVisible    to true

            send ShowToolTip      of ToolTipObject sTip
        end
        else send HideToolTip
    end_procedure

    //====================================================================================
    //  Name         : HideToolTip
    //  Scope        : PRIVATE
    //  Purpose      : get rid of the current tool tip
    //====================================================================================
    procedure HideToolTip
        integer currentTipObj
        if (ToolTipVisible(self)) begin
            get LastToolTipObject to currentTipObj
            send HideToolTip      of currentTipObj
            set ToolTipVisible    to false
        end
    end_procedure

    //====================================================================================
    //  Name         : ChangeTimerInterval
    //  Scope        : PRIVATE
    //  Purpose      : Hook to change timer interval.  This is because PlusPak! cTimer
    //               : must be stopped and started to change the timer interval
    //====================================================================================
    procedure ChangeTimerInterval integer NewInterval
       if (IsRunning(current_object)) send DoStop
       set piInterval to NewInterval
       send DoStart
    end_procedure

    //====================================================================================
    //  Name         : CheckHint
    //  Scope        : PRIVATE
    //  Purpose      : check to see if a tool tip should be shown
    //====================================================================================
    procedure CheckHint
        integer isTipActive
//        integer showTip
        integer iobj iItem
        string  sTip

        get ToolTipVisible to isTipActive      // are we already displaying one?
        move (GetDFObjectUnderMouse()) to iObj // what is the current df object
        if (iObj > 0) begin
            // we have an object
            // get the tool tip string
            //get ShowTooltip of iObj to showTip        // do we display a hint
            //if (showTip) get TooltipHint of iObj to sTip  // and what is it
            get TooltipHint of iObj to sTip
            // 2001-10-16 ------------------------------------ Start Nils G. Svedmyr
//            If (Trim(sTip) = "" and pbTooltip(Self)) Get Status_Help of iObj item (Current_Item(iObj)) to sTip
            If (Trim(sTip) = "" and pbTooltip(Self)) Begin
              Get Item_Count  Of iObj To iItem
              If iItem Get Current_Item Of iObj To iItem
              Get Status_Help of iObj item iItem to sTip
            End // If (Trim(sTip) = "" and pbTooltip(Self)) Begin
            // 2001-10-16 ------------------------------------ Stop Nils G. Svedmyr
        end

        if isTipActive begin
            // the tool tip is active, so we either want to turn it off or we've moved to a different object
            if (sTip <> "") begin
                // the tool tip is active and we have something to show
                send ShowToolTip (TooltipHintObject(iObj)) sTip
            end
            else begin
                // the tool tip is active and we don't want to show one
                send HideToolTip
                send ChangeTimerInterval 1000
            end
        end
        else begin
            // the tool tip is not active
            if (sTip <> "") begin
                // the tool tip is not active and we have something to show
                send ShowToolTip (TooltipHintObject(iObj)) sTip
                send ChangeTimerInterval 200 // make the timer check more (smoother transition from object to object)
            end
            else begin
                // the tool tip is not active and we don't want to show one
                // nothing to do
            end
        end
    end_procedure

    //====================================================================================
    //  Name         : CheckRemoveToolTip
    //  Scope        : PRIVATE
    //  Purpose      : Check to see if we should hide the tool tip, given that it should
    //               : not be there!
    //====================================================================================
    procedure CheckRemoveToolTip
        // if the tool tip is active, then get rid of it.
        if (ToolTipVisible(self)) begin
            send HideToolTip
            // SGM : 21/10/1997
            // added this - slow the timer down if we removed it.
            send ChangeTimerInterval 1000
        end
    end_procedure

    //====================================================================================
    //  Name         : MouseIsOverWindow
    //  Scope        : PRIVATE
    //  Purpose      : returns true if the mouse is over this window
    //====================================================================================
    function MouseIsOverWindow handle hWind returns integer
        string  pnt       // a TOOLTIP_POINT type
        pointer pPnt      // a pointer to TOOLTIP_POINT
        string  rect      // a tRECT type
        pointer pRect     // a pointer to tRECT
        integer mx        // mouse x
        integer my        // mouse y
        integer winLeft   // win left loc
        integer winTop    // win top loc
        integer winRight  // win right loc
        integer winBottom // win bottom loc

        // get the location of the mouse
        filltype TOOLTIP_POINT with 0 to pnt
        GetAddress of pnt to pPnt
        move (GetCursorPos(pPnt)) to windowindex
        getbuff from pnt at TOOLTIP_POINT.X to mx
        getbuff from pnt at TOOLTIP_POINT.Y to my

        // get the _real_ origin and extent of the application
        // using DF's Absolute_GuiOrigin returns us the loctions offset by the
        // apps caption bar which just causes too many problems

        filltype tRECT with 0 to rect
        GetAddress of rect to pRect
        move (GetWindowRect(hWind, pRect)) to windowindex
        getbuff from rect at tRECT.left    to winLeft
        getbuff from rect at tRECT.top     to winTop
        getbuff from rect at tRECT.right   to winRight
        getbuff from rect at tRECT.bottom  to winBottom

        function_return (((mx > winLeft) and (mx < winRight)) and ((my > winTop) and (my < winBottom)))
    end_function

    //====================================================================================
    //  Name         : OnTimer
    //  Scope        : PRIVATE
    //  Purpose      : A timer event has gone, do the checks
    //====================================================================================
    procedure OnTimer
        handle  hdMain
        handle  hd
        integer iFoc

        // we have to determine if we are the active window because if there is another df app running
        // we will get the df object of the object in the other app if the mouse is located there.

        // this causes us to get an unresolved object reference because we're trying to talk to an object
        // that isn't even in this program!

        move (GetActiveWindow())                    to hd      // the active (DF) window.

        // if the active window handle doesn't equal the window handle of 'main' then we are either dealing
        // with a modal panel (within our app) or some other app has the windows focus.  what we need to
        // do now is get the window handle of the panel that is the parent of the focus and check
        // that against the active window.

        // get the focus
        get Focus to iFoc
        // get the window handle of the panel that is the parent (or grand.. parent) of the focus.
        get WindowHandleForToolTip of iFoc to hdMain             // the handle of the window (panel) that has the focus

        // do the tests.
        if (hd = hdMain) begin
            // the active window is the same as the panel with the focus,
            // but is the mouse over the active window?
            if (MouseIsOverWindow(self, hd)) begin
                // the window for this app is active and the mouse is actually over the application
                // not a different VDF
                // check for tool tip hints
                send CheckHint
            end
            else send CheckRemoveToolTip   // remove the tool tip if it is active
        end
        else send CheckRemoveToolTip       // remove the tool tip if it is active

    end_procedure

    //====================================================================================
    //  Name         : DisableToolTips
    //  Scope        : PUBLIC
    //  Purpose      : Turn off tool tips
    //====================================================================================
    procedure DisableToolTips
      send DoStop
    end_procedure

    //====================================================================================
    //  Name         : EnableToolTips
    //  Scope        : PUBLIC
    //  Purpose      : Turn on tool tips
    //====================================================================================
    procedure EnableToolTips
      send DoStart
    end_procedure

end_class

object oStandardToolTip is a StandardToolTip000
    move self to DefaultTooltipHintID
end_object

object oToolTipTimer is a ToolTipTimer000
    move Self to TooltipControllerID
    Send DoStart
end_object