2010-12-07 21:18

'
' RapidFRM.inc (include file for RapidFRM.bas v1.41 and above)
'
' 1. Moved the mouse Decl/Func etc out of mainline code to assist in debugging
'    using RapidDBG. (NO debugging is applied to "$INCLUDE..." files).
' 2. QCOLORDLG - Fix for QColorDialog (pre-RAPIDQ2.INC v1.4e). Using this code
'    in case other users have not upgraded RAPIDQ2.INC v1.4e or greater.
' 3. QTABCONTROL - Some extra functionality.
'

'---------------------------------------- API Declarations ---------------------------------------------
     DECLARE FUNCTION GetActiveWindow LIB "user32" ALIAS "GetActiveWindow" () AS LONG
     DECLARE FUNCTION WindowFromPoint LIB "user32" ALIAS "WindowFromPoint" (X AS LONG, Y AS LONG) AS LONG
     DECLARE FUNCTION DestroyWindow LIB "user32" ALIAS "DestroyWindow" (hWnd AS LONG) AS LONG
     DECLARE FUNCTION ScreenToClient LIB "user32" ALIAS "ScreenToClient" (hWnd AS LONG, lpPoint AS POINTAPI) AS LONG
     DECLARE FUNCTION UpdateWindow LIB "user32" ALIAS "UpdateWindow" (hWnd AS LONG) AS INTEGER
     DECLARE FUNCTION InvalidateRect LIB "user32" ALIAS "InvalidateRect" (hWnd AS LONG, rect AS QRECT, bErase AS LONG) AS LONG
     DECLARE FUNCTION SetBkColor LIB "gdi32" ALIAS "SetBkColor" (hdc AS LONG, crColor AS LONG) AS LONG


     DECLARE FUNCTION SetWindowsHookEx LIB "user32" ALIAS "SetWindowsHookExA" (idHook AS LONG, lpFn AS LONG, _
      hmod AS LONG, dwThreadId AS DWORD) AS LONG
     DECLARE FUNCTION CallNextHookEx LIB "user32" ALIAS "CallNextHookEx" (hHook AS LONG, nCode AS LONG, _
      wParam AS LONG, lParam AS LONG) AS LONG
     DECLARE FUNCTION UnhookWindowsHookEx LIB "user32" ALIAS "UnhookWindowsHookEx" (hHook AS LONG) AS LONG
     DECLARE FUNCTION GetCurrentThreadId LIB "kernel32" ALIAS "GetCurrentThreadId" () AS LONG

'---------------------------------------------------------------------------------------------------------
' 1. MouseHook Stuff (see Initialise() in RapidFRM.bas for setting this up)
     $DEFINE LMOUSE_BTN 1                                            ' Left Mouse Button
     $DEFINE RMOUSE_BTN 2                                            ' Right Mouse Button
     $DEFINE MMOUSE_BTN 4                                            ' Middle Mouse Button

     DEFLNG lpHookProc, ThreadID, hHook                              ' Vars for hooking the mouse
     DEFINT gMouseBtns                                               ' My (global) mouse btns

' Here, ONLY interested in the mouse buttons (wParam)
' For info: MouseX = LOWORD(lParam): MouseY = HIWORD(lParam)
     FUNCTION MouseProc(idHook AS LONG, wParam AS LONG, lParam AS LONG) AS LONG
      DEFLNG tmp

      IF idHook >= 0 THEN                                         ' If < 0 no processing required
       tmp=wParam AND 15
       SELECT CASE tmp
       CASE 1: gMouseBtns=LMOUSE_BTN                       ' Update our global mouse btns
       CASE 2: gMouseBtns=0
       CASE 4: gMouseBtns=RMOUSE_BTN
       CASE 5: gMouseBtns=0
       CASE 7: gMouseBtns=MMOUSE_BTN                       ' Don't use this but...
       CASE 8: gMouseBtns=0
       END SELECT
      END IF
      Result=CallNextHookEx(hHook, idHook, wParam, lParam)        ' Call the next hook
     END FUNCTION

'---------------------------------------------------------------------------------------------------------
' 2. Bug fix for QCOLORDIALOG component
'   Position anywhere on-screen &/or relative to other objects
'   Dialog height fixed; dialog width dependant on style property
'   Change dialog caption, if required
'
     $DEFINE cdNormal 0                                              ' ColorChooser Styles
     $DEFINE cdFullOpen 1
     $DEFINE cdNoFullOpen 2

     $DEFINE CHOOSER_HEIGHT 335                                      ' Height of ColorChooser window
     $DEFINE CHOOSER_STD 225                                         ' Width of window when in compact style
     $DEFINE CHOOSER_FULL 460                                        ' Width of window when in full style

     TYPE QColorDlg EXTENDS QFORM
PUBLIC:
    ' Left & Top    -> properties of QFORM
      Width           AS LONG PROPERTY SET SetWidth               ' Force READ ONLY of this property
      Height          AS LONG PROPERTY SET SetHeight              '            ditto
      Style           AS LONG PROPERTY SET SetStyle               ' cdNoFullOpen, cdFullOpen (cdNormal for compat.)
      CAPTION         AS STRING                                   ' Adjustable in RapidFRM v1.43
      COLOR           AS LONG                                     ' Selected color
      Colors(1 TO 16) AS LONG                                     ' Custom colors
      WindowHandle    AS LONG                                     ' Not Used

PRIVATE:
      CC              AS CHOOSECOLOR
      ccTimer         AS QTIMER                                   ' Used to change the caption of CC

      WITH QColorDlg

' IF CC window visible, change the caption
       SUB SetChooserCaption
        DEFLNG hWnd
        DEFSTR buf=SPACE$(6)

        .ccTimer.Enabled=False                                      ' Disable
        hWnd=WindowFromPoint(.Left+50, .Top+50)                     ' Handle of CC window?
        IF GetWindowText(hWnd,buf,6) THEN
         IF INSTR(buf,"Color")>0 THEN                            ' The default caption?
          SetWindowText(hWnd, .CAPTION)                       ' Set the new caption
         END IF
        END IF
       END SUB

PUBLIC:

       FUNCTION EXECUTE() AS INTEGER
        Result=0
        .CC.lStructSize = SIZEOF(THIS.CC)
        .CC.hWndOwner = .Handle
        .CC.hInstance = 0
        .CC.RGBResult = .COLOR
        .CC.lpCustColors = VARPTR(THIS.Colors(1))               ' Set the pointer to the custom colors
        SELECT CASE .Style
        CASE cdFullOpen, cdNormal
         .CC.Flags = .CC.Flags OR CC_FULLOPEN
        CASE cdNoFullOpen
         .CC.Flags = .CC.Flags OR CC_PREVENTFULLOPEN
        END SELECT
        .ccTimer.Enabled=True                                   ' Start one-shot timer to replace caption
        IF ChooseColorDlg(THIS.CC) THEN                         ' Call the Color select Dialog
         .COLOR = .CC.RGBResult                              ' Update user selected color
         Result=1
        END IF
       END FUNCTION

       PROPERTY SET SetStyle (ccStyle AS LONG)
        .Style = ccStyle
        IF ccStyle = cdNoFullOpen THEN .Width = CHOOSER_STD ELSE .Width = CHOOSER_FULL
       END PROPERTY

       PROPERTY SET SetWidth (W AS LONG)
    ' READONLY property
       END PROPERTY

       PROPERTY SET SetHeight (H AS LONG)
    ' READONLY property
       END PROPERTY

       CONSTRUCTOR
        Style=cdNoFullOpen                                      ' Default to compact mode
        Width=CHOOSER_STD                                       ' Compact mode width
        Height=CHOOSER_HEIGHT                                   ' Default height (either mode)
        Left=(Screen.Width-CHOOSER_STD)\2                       ' Defaults center of screen
        Top=(Screen.Height-CHOOSER_HEIGHT)\2                    ' ditto
        BorderStyle=0                                           ' Blank form
        CAPTION="Choose a Color"                                ' Default caption of chooser dialog
        ccTimer.OnTimer=THIS.SetChooserCaption                  ' One-shot timer to replace caption
        ccTimer.Interval=50                                     ' Timeout delay period
        ccTimer.Enabled=False                                   ' Default disabled
        WindowHandle=THIS.Handle                                ' Not used
        CC.Flags=CC_RGBINIT                                     ' Set to default system color set
        Colors(1)=&H0                                           ' Custom colors (if used)
        Colors(2)=&H808080
        Colors(3)=&H000080
        Colors(4)=&H008080
        Colors(5)=&H008000
        Colors(6)=&H808000
        Colors(7)=&H800000
        Colors(8)=&H800080
        Colors(9)=&HFFFFFF
        Colors(10)=&HC0C0C0
        Colors(11)=&H0000FF
        Colors(12)=&H00FFFF
        Colors(13)=&H00FF00
        Colors(14)=&HFFFF00
        Colors(15)=&HFF0000
        Colors(16)=&HFF00FF
       END CONSTRUCTOR
      END WITH
     END TYPE

'---------------------------------------------------------------------------------------------------------
' 3. QTABCONTROL - extra funcs for adding/editing TABs when ONLY the handle is
' available (an unfortunate legacy when creating components at the "local" level).
'
' Some of the uMsg constants
     $DEFINE TCM_SETIMAGELIST &H1303
     $DEFINE TCM_GETITEMCOUNT &H1304
     $DEFINE TCM_SETITEM &H1306
     $DEFINE TCM_INSERTITEM &H1307
     $DEFINE TCM_DELETEITEM &H1308
     $DEFINE TCM_DELETEALLITEMS &H1309
     $DEFINE TCM_GETITEMRECT &H130A
' Mask values
     $DEFINE TCIF_TEXT &H1
     $DEFINE TCIF_IMAGE &H2
     $DEFINE TCIF_RTLREADING &H4
     $DEFINE TCIF_PARAM &H8
     $DEFINE TCIF_STATE &H10

     TYPE TabTCITEMHEADER
      mask AS LONG
      Reserved1 AS LONG
      Reserved2 AS LONG
      lpszText AS LONG
      cchTextMax AS INTEGER
      iImage AS INTEGER
     END TYPE

     FUNCTION GetTabCount(TabHandle AS LONG) AS INTEGER
      Result=SendMessageAPI(TabHandle, TCM_GETITEMCOUNT, 0, 0)
     END FUNCTION

     FUNCTION DelAllTabs(TabHandle AS LONG) AS INTEGER
      Result=0
      IF GetTabCount(TabHandle)>0 THEN
       Result=SendMessageAPI(TabHandle, TCM_DELETEALLITEMS, 0, 0)
      END IF
     END FUNCTION

' NB IF TabIndex>=numTabs+1 - just adds to end - else will insert between TABs
     FUNCTION AddNewTab(TabHandle AS LONG, TabIndex AS INTEGER, TabText AS STRING) AS INTEGER
      DEFSTR tmpString
      DIM TabHdr AS TabTCITEMHEADER

      Result=0
      IF TabIndex<0 THEN EXIT FUNCTION
      tmpString=TabText+CHR$(0)                                       ' Ensure Null termination
      TabHdr.lpszText=VARPTR(tmpString)                               ' Ptr to string
      TabHdr.mask=TCIF_TEXT                                           ' Set mask
      TabHdr.iImage=-1                                                ' image index or -1
      Result=SendMessageAPI(TabHandle, TCM_INSERTITEM, TabIndex, TabHdr)      ' returns index #
     END FUNCTION

2010-12-07 21:18