2013-06-21 21:13

' This is freeware to help Rapid-Q users to enjoy the power of that great
' Basic language, note that use in your own risk.
' Any update of this file please upload here:
'  
' and feedback here:
'  http://lab.cjb.net/?a=f&b=6
' Created by Leon Wang 2002-8-11

'string[index], first index =1
     $INCLUDE "rapidq.inc"
     CONST WM_LBUTTONUP = &H202
     CONST GWL_HWNDPARENT = (-8)
     CONST HWND_DESKTOP = 0
     CONST GWL_WNDPROC=(-4)
     CONST WM_ACTIVATE = &H6
     CONST WA_ACTIVE = 1
     CONST WA_INACTIVE = 0
     Public CONST SW_HIDE = 0
     Public CONST SW_NORMAL = 1
     Public CONST SW_SHOW = 5
     Public CONST SW_restore = 9
     Public CONST MB_ICONEXCLAMATION = &H30&
     Public CONST FILE_ATTRIBUTE_READONLY = &H1
     Public CONST FILE_ATTRIBUTE_HIDDEN = &H2
     Public CONST FILE_ATTRIBUTE_SYSTEM = &H4
     Public CONST FILE_ATTRIBUTE_ARCHIVE = &H20
     Public CONST FILE_ATTRIBUTE_NORMAL = &H80
     Public CONST WM_SETFOCUS = &H7
     Public CONST WM_CLOSE = &H10
     Public CONST WM_QUERYENDSESSION = &H11
     Public CONST WM_QUIT = &H12
     DIM monitorsize AS INTEGER
     DIM OldwndProc AS LONG
'Declare Function BringWindowToTop Lib "user32.dll" alias "BringWindowToTop" (ByVal hwnd As Long) As Long
'Declare Function EnableWindow Lib "user32.dll" alias "EnableWindow" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
     DECLARE FUNCTION SetActiveWindow LIB "user32.dll" ALIAS "SetActiveWindow" (BYVAL hwnd AS LONG) AS LONG
     DECLARE FUNCTION CallWindowProc LIB "user32" ALIAS "CallWindowProcA" (lpPrevWndFunc AS LONG, hwnd AS LONG, msg AS LONG, wParam AS LONG, lParam AS LONG) AS LONG
     DECLARE FUNCTION SetWindowLong LIB "user32" ALIAS "SetWindowLongA" (hwnd AS LONG, nIndex AS LONG, dwNewLong AS LONG) AS LONG
     DECLARE FUNCTION ShowWindow LIB "user32" ALIAS "ShowWindow" (BYVAL hwnd AS LONG, BYVAL nCmdShow AS LONG) AS LONG
     DECLARE FUNCTION CopyFile LIB "kernel32" ALIAS "CopyFileA" (BYVAL lpExistingFileName AS STRING, BYVAL lpNewFileName AS STRING, BYVAL bFailIfExists AS LONG) AS LONG
     DECLARE FUNCTION GetFileAttributes LIB "kernel32" ALIAS "GetFileAttributesA" (BYVAL lpFileName AS STRING) AS LONG
     DECLARE FUNCTION SetFileAttributes LIB "kernel32" ALIAS "SetFileAttributesA" (BYVAL lpFileName AS STRING, BYVAL dwFileAttributes AS LONG) AS LONG
     DECLARE FUNCTION SetFocus LIB "user32" ALIAS "SetFocus" (BYVAL hwnd AS LONG) AS LONG
     DECLARE FUNCTION GetFocus LIB "user32" ALIAS "GetFocus" () AS LONG
     DECLARE FUNCTION setfontsize(s) AS SINGLE
     $ESCAPECHARS ON
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Objects '''
' An alternative Label object since QLabel can not display multi-byte charactors correctly
' such as Chinese string will be overlapped a little bit and trimed at left and right end
'Note: MUST use in this way (height,width won't be set correctly if use form.showmodal):
'     form.show
'     doevents 'must before setting left,top etc.
'     wlabel.left=...
'     wlabel.top=...
'     ...
'     do : doevents : loop until form.visible=false

     TYPE QWLabel EXTENDS QCANVAS
      alignment AS INTEGER
      labelstyle AS INTEGER 'property set setlabelstyle
      autosize AS INTEGER PROPERTY SET setautosize
      CAPTION AS STRING PROPERTY SET setcaption
'  HiLightColor AS INTEGER
      lines AS QSTRINGLIST
      linespace AS SINGLE

      WITH this
       FUNCTION gettextwidth(maxstring AS STRING) AS INTEGER
        IF RTRIM$(maxstring)="" THEN result=0 : EXIT FUNCTION
        result=.textwidth(maxstring)'+ w *.font.size/4.2'.textwidth("w")/4.5
       END FUNCTION
       SUB reautosize
        .height=.textheight(.CAPTION)*(.lines.itemcount*.linespace)+1
'    .height=.h
        DEFINT il,maxwidth=0,lenl
        DEFSTR maxstring,l1
        FOR il=0 TO .lines.itemcount-1
         l1=.lines.item(il)
         lenl=LEN(l1)
         IF maxwidth<lenl THEN
          maxwidth=lenl : maxstring=l1
         END IF
        NEXT il
        .width=.gettextwidth(maxstring)+4
'    .width=.w
       END SUB
       SUB redraw
        DEFINT textleft=1 'default taleftjustify
        DEFINT i
        DEFSTR l1
        IF .autosize<>false THEN .reautosize
'   .rectangle(0,0,.width,.height,clblue)

        FOR i=0 TO .lines.itemcount-1
         l1=.lines.item(i)
         SELECT CASE .alignment
         CASE tacenter
          textleft=(.width-.gettextwidth(l1))\2'+1
         CASE tarightjustify
          textleft=.width-.gettextwidth(l1)-2'+1
         END SELECT
         .TextOut(textleft,i*.textheight(l1)*.linespace+2, l1, .font.COLOR, -1)
        NEXT
       END SUB
       PROPERTY SET setautosize(newautosize AS INTEGER)
        IF .autosize<>newautosize THEN
         .autosize=newautosize
         IF newautosize<>false THEN .reautosize
         .redraw
        END IF
       END PROPERTY
       PROPERTY SET setcaption(newcaption AS STRING)
        .CAPTION=newcaption
        .lines.clear
        .lines.parse(newcaption,"\n")
        IF .autosize<>false THEN
         .reautosize
        END IF
        .redraw
       END PROPERTY
'  property set setlabelstyle(newlabelstyle as integer)
'   .labelstyle=newlabelstyle
'   .redraw
'  end property
       EVENT OnPaint
        .redraw
       END EVENT

       CONSTRUCTOR
        linespace=1.2
        autosize=false
        alignment=taleftjustify
        CAPTION = "QWLabel"
        lines.parse(.CAPTION,"\n")
'    HiLightColor = &H00FF00
       END CONSTRUCTOR
      END WITH
     END TYPE
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Functions ''''
     FUNCTION basename(s AS STRING) AS STRING
      $ESCAPECHARS off
      DEFINT p1=rinstr(s,"\"),l=LEN(s)
      IF p1>=l THEN result="" ELSE result=MID$(s,p1+1)
     END FUNCTION
     FUNCTION like(s AS STRING,mask AS STRING) AS INTEGER
' blank mask = false
      DIM findpos AS INTEGER
      DEFINT start=1,i,j,l,l1,maskp=1,sp=1,masklen,maskp2=maskp
      DEFSTR s1,s2
      l=LEN(s)
      masklen=LEN(mask)
      IF masklen<=0 THEN
       IF l<=0 THEN like=true ELSE like=false
       EXIT FUNCTION
      END IF
      like=true
      DO
       IF mask[maskp]="*" THEN
        DO
         maskp++
         IF maskp>masklen THEN EXIT FUNCTION
        LOOP UNTIL mask[maskp]<>"*" 'maskp -> maskp2 not "*"
        maskp2=maskp
        WHILE mask[maskp2+1]<>"*" AND mask[maskp2+1]<>"?"
         IF maskp2<masklen THEN maskp2++ ELSE EXIT WHILE
        WEND
        DEFSTR m1=MID$(mask,maskp,maskp2-maskp+1)
        findpos=INSTR(sp,s,m1)
        IF findpos=0 THEN like=false : EXIT FUNCTION
        sp=findpos+(maskp2-maskp+1)
        IF sp>=l THEN EXIT FUNCTION
        maskp=maskp2+1
       ELSEIF mask[maskp]="?" THEN
        IF maskp>=masklen THEN 'the end
         IF sp>=l THEN
          EXIT FUNCTION
         ELSE
          result=false:EXIT FUNCTION
         END IF
        ELSE
         maskp++ : sp++
         IF sp>l THEN result=false: EXIT FUNCTION
        END IF
       ELSE
        IF mask[maskp]<>s[sp] THEN
         result=false: EXIT FUNCTION
        ELSE
         maskp++ : sp++
        END IF
       END IF
      LOOP UNTIL maskp>masklen OR sp>l
     END FUNCTION
'QRegistry
'HKEY_CLASSES_ROOT = &H80000000
'HKEY_CURRENT_USER = &H80000001
'HKEY_LOCAL_MACHINE = &H80000002
'HKEY_USERS = &H80000003
'HKEY_CURRENT_CONFIG = &H80000004
'HKEY_DYN_DATA = &H80000005
     SUB iniWriteint(section AS STRING,keyname AS STRING, _
       defaultvalue AS INTEGER, myinifile AS QREGISTRY)
      myinifile.openkey( application.title & "\" & section,true)
      myinifile.writeinteger(keyname,defaultvalue)
      myinifile.closekey
     END SUB
     FUNCTION inireadstring(section AS STRING,keyname AS STRING, _
       defaultvalue AS STRING, myinifile AS QREGISTRY) AS STRING
      myinifile.openkey( application.title & "\" & section,false)
      IF myinifile.valueexists(keyname) THEN
       inireadstring=myinifile.readstring(keyname)
      ELSE
       inireadstring=defaultvalue
      END IF
      myinifile.closekey
     END FUNCTION
     SUB iniwritestring(section AS STRING,keyname AS STRING, _
       defaultvalue AS STRING, myinifile AS QREGISTRY)
      myinifile.openkey( application.title & "\" & section,true)
      myinifile.writestring(keyname,defaultvalue)
      myinifile.closekey
     END SUB
     FUNCTION inireadint(section AS STRING,keyname AS STRING, _
       defaultvalue AS INTEGER, myinifile AS QREGISTRY) AS INTEGER
      myinifile.openkey( application.title & "\" & section,false)
      IF myinifile.valueexists(keyname) THEN
       inireadint=myinifile.readinteger(keyname)
      ELSE
       inireadint=defaultvalue
      END IF
      myinifile.closekey
     END FUNCTION
     FUNCTION setfontsize(s) AS SINGLE
      setfontsize=.025 * s * screen.height / monitorsize
     END FUNCTION
' This program detects if a previous instance of itself is already active.
' For example, you may not want the user to load 2 instances of your program.
' If found, the previous instance is brought to the foreground, even if it
' was minimized it should restore itself.

' Run this program twice to see the affect

     CONST rqClassName = "TForm"        '-- Classname for all Rapid-Q programs

'FindWindow searches all windows for one which matches the window class name
' and/or window name. The function's searching mechanism is not case
'-sensitive. If you do not wish to specify one of the parameters, pass a null
' string for it.

'Return Value
'If successful, the function returns a handle to the window that was found.
' If no matching window could be found, or if an error occured, the function
' returns zero (use GetLastError to get the error code).
     DECLARE FUNCTION FindWindow LIB "USER32" ALIAS "FindWindowA" _
      (className AS STRING, windowName AS STRING) AS INTEGER
     DECLARE SUB SetForegroundWindow LIB "USER32" ALIAS "SetForegroundWindow" (HWnd AS LONG)
'DECLARE SUB ShowWindow LIB "USER32" ALIAS "ShowWindow" _
'                 (HWnd AS LONG, nCmd AS LONG)
     FUNCTION AppPrevInstance(myFormName AS STRING) AS INTEGER
      DEFINT hWnd = FindWindow(rqClassName, myFormName)
' IF hWnd THEN
'    ShowMessage ("A previous instance was detected")
'    SetForegroundWindow(hWnd)
'    ShowWindow(hWnd, 1)
'    END
' END IF
      AppPrevInstance=hwnd
     END FUNCTION
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' QBrowseDialog ''''''''''
'================= QBrowseDialog =======================

' A little easier to use than QDirTree when all you
' want is the name of a folder...

' It has familiar properties:

' Caption is the string that appears in the title bar
' Title is the string that appears over the treeview
' InitialDir is the folder that is hilighted on startup
' Directory is the folder that was selected

' Like QOpenDialog, QSaveDialog, and QColorDialog, you
' DIM or CREATE it in code. To show the dialog, call
' <Name>.Execute. If the user presses "OK", the function
' returns 1. If the user presses "Cancel" or closes the
' Dialog, the result is 0. This Dialog also returns
' virtual folders like the Recycle Bin and Fonts folder,
' although in name only (you can't access these folders
' by path). Use it in good health!

' Psyclops ?



     TYPE BROWSEINFO                  ' structure to pass to the API
      hWndOwner      AS LONG       ' remove icon from taskbar
      pIDLRoot       AS LONG       ' first visible folder (0 for Desktop)
      pszDisplayName AS LONG       ' buffer for folder name (not path!)
      lpszTitle      AS LONG       ' buffer for Title string
      ulFlags        AS LONG       ' ???
      lpfnCallback   AS LONG       ' pointer to window proc
      lParam         AS LONG       ' pointer to InitialDir
      iImage         AS LONG       ' ???
     END TYPE

     CONST BIF_RETURNONLYFSDIRS = 1          ' only select folders
     CONST MAX_PATH             = 260        ' buffer length
     CONST BFFM_INITIALIZED     = 1          ' for the hook
     CONST BFFM_SETSELECTIONA   = &H466      ' sets InitialDir

     DECLARE SUB CoTaskMemFree LIB "Ole32" ALIAS "CoTaskMemFree"(hMem AS LONG)          ' clear pidList from memory
     DECLARE FUNCTION SHBrowseForFolder LIB "Shell32" ALIAS "SHBrowseForFolder"_        ' the API!
      (lpbi AS BROWSEINFO) AS LONG
     DECLARE FUNCTION SHGetPathFromIDList LIB "Shell32" ALIAS "SHGetPathFromIDList"_    ' changes result of API to string
      (pidList AS LONG, lpBuffer AS STRING) AS LONG
     DECLARE FUNCTION GetWindowRect LIB "User32" ALIAS "GetWindowRect"_                 ' for centering
      (hWnd AS LONG, lpRect AS QRECT) AS LONG
     DECLARE FUNCTION MoveWindow LIB "User32" ALIAS "MoveWindow"_                       ' same as above
      (hWnd AS LONG, x AS LONG, y AS LONG,nWidth AS LONG,_
      nHeight AS LONG, bRepaint AS LONG) AS LONG
     DECLARE FUNCTION SetWindowText LIB "user32" ALIAS "SetWindowTextA"_                ' sets titlebar caption
      (hWnd AS LONG, ByRef lpString AS STRING) AS LONG

     TYPE QBROWSEDIALOG EXTENDS QOBJECT
      WITH QBROWSEDIALOG

       CAPTION    AS STRING
       Title      AS STRING
       InitialDir AS STRING
       Directory  AS STRING
       X          AS STRING

       FUNCTION BrowseHook(hWnd AS LONG, uMsg AS LONG, lParam AS LONG, lpData AS LONG) AS LONG
        IF uMsg = BFFM_INITIALIZED THEN                           ' Dialog is done drawing
         DIM R AS QRECT
         GetWindowRect(hWnd, R)
         MoveWindow (hWnd, (Screen.Width-(R.Right-R.Left))/2, (Screen.Height-(R.Bottom-R.Top))/2,_
          (R.Right-R.Left), (R.Bottom-R.Top), 0)     ' center it
         SendMessage(hWnd, BFFM_SETSELECTIONA, 1, lpData)      ' set InitialDir
         IF LEN(.CAPTION) THEN                                 ' if caption, set it
          SetWindowText(hWnd, .CAPTION)                     ' otherwise use default
         END IF                                                ' ("Browse for folder")
        END IF
       END FUNCTION

       FUNCTION EXECUTE AS LONG
        DIM BI AS BROWSEINFO                                      ' DIM our structure
        DIM pidl AS LONG                                          ' result of API
        DIM sPath AS STRING*MAX_PATH                              ' result string
        DIM xPath AS STRING*MAX_PATH                              ' Virtual Folder result
        .InitialDir = .InitialDir + CHR$(0)                       ' add null terminator
        BI.hWndOwner = Application.Handle
        BI.pszDisplayName = VARPTR(xPath)
        BI.lpszTitle = VARPTR(This.Title)
        BI.lpfnCallback = CODEPTR(This.BrowseHook)
        BI.lParam = VARPTR(This.InitialDir)
        pidl = SHBrowseForFolder(BI)                                  ' do it!
        IF pidl THEN                                                  ' if API succeeds,
         IF SHGetPathFromIDList(pidl, sPath) THEN                  ' check for path string
          .Directory = LEFT$(sPath, INSTR(sPath, CHR$(0))-1)    ' if yes, knock off null terminator
         ELSE                                                      ' or else
          .Directory = LEFT$(xPath, INSTR(xPath, CHR$(0))-1)    ' get name string (Virual Folders)
         END IF
         CoTaskMemFree pidl                                        ' free memory
         Result = 1                                                ' success!
        ELSE
         Result = 0                                                ' failure :(
        END IF
       END FUNCTION



      END WITH
     END TYPE
' How to put your application icon into the system tray area.
' Double click your icon to "re-display" the application.
' Written in Rapid-Q by William Yu

     $TYPECHECK ON

     TYPE TNOTIFYICONDATA
      cbSize AS DWORD
      hWnd AS LONG
      uID AS LONG
      uFlags AS LONG
      uCallbackMessage AS LONG
      hIcon AS LONG
      szTip AS STRING*64
     END TYPE

     DECLARE SUB Shell_NotifyIcon LIB "SHELL32" ALIAS "Shell_NotifyIconA" _
      (dwMessage AS LONG, NIDATA AS TNOTIFYICONDATA)

'CONST FALSE = 0
'CONST TRUE = 1

     CONST NIM_ADD = 0
     CONST NIM_MODIFY = 1
     CONST NIM_DELETE = 2

     CONST NIM_MESSAGE = 1
     CONST NIM_ICON = 2
     CONST NIM_TIP = 4

     CONST WM_USER = &H400
     CONST WM_TRAYICON = WM_USER + 400

     CONST WM_COMMAND = &H111
     CONST WM_SYSCOMMAND = &H112

     CONST WM_LBUTTONDOWN = &H201
     CONST WM_LBUTTONDBLCLK = &H203
     CONST WM_RBUTTONDOWN = &H204
     CONST WM_RBUTTONDBLCLK = &H206

     CONST SC_MINIMIZE = 61472
     CONST SC_CLOSE = 61536

'DIM Form AS QForm
'DIM Button AS QButton
     DIM NI AS TNotifyIconData
     DEFINT AlreadyTrayed=false
'Button.Parent = Form
'Button.Caption = "Tray me"
'Button.OnClick = ButtonClick

'Form.Caption = "Tray Example"
'Form.Center
'Form.OnClose = FormClose
'Form.WndProc = FormWndProc
'Form.ShowModal

2013-06-21 21:13