Guidance
指路人
g.yi.org
software / rapidq / Examples / Database / RQ-ADS / Xbrow.bas

Register 
注册
Search 搜索
首页 
Home Home
Software
Upload

  
'Sample Rapid-Q & Advantage Database Local Server code
'-----------------------------------------------------
     $TYPECHECK ON
     $APPTYPE GUI
     $OPTION ICON "database.ico"
     $OPTIMIZE ON
     $INCLUDE "RAPIDQ.INC"
     $INCLUDE "ACE32.INC"
'
     CONST LVM_FIRST = &H1000
     CONST LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 54
     CONST LVM_DELETECOLUMN = LVM_FIRST + 28
     CONST LVEX_GRIDLINES = 1
     CONST LVEX_SUBITEMIMAGES = 2
     CONST LVEX_CHECKBOXES = 4
     CONST LVEX_TRACKSELECT = 8
     CONST LVEX_HEADERDRAGDROP = 16
     CONST LVEX_FULLROWSELECT = 32
     CONST LVEX_ONECLICKACTIVATE = 64
     CONST LVEX_TWOCLICKACTIVATE = 128
     CONST WS_EX_CLIENTEDGE = &H200       ' Just some of the many API constants
     CONST WM_COMMAND = &H111

     CONST BN_CLICKED = 0
     CONST BN_PAINT = 1
     CONST BN_HILITE = 2           '** Pushed   **
     CONST BN_UNHILITE = 3         '** UnPushed **
     CONST BM_DOUBLECLICKED = 4    '** There's more... **

     PUBLIC CONST LVCF_FMT=1
     PUBLIC CONST LVCF_WIDTH=2
     PUBLIC CONST LVCF_TEXT=4
     PUBLIC CONST LVCF_SUBITEM=8
     PUBLIC CONST LVCFMT_LEFT=0
     PUBLIC CONST LVCFMT_RIGHT=1
     PUBLIC CONST LVCFMT_CENTER=2
     PUBLIC CONST LVCFMT_JUSTIFYMASK=3
'
     Public CONST WS_OVERLAPPED = &H0&
     Public CONST WS_POPUP = &H80000000
     Public CONST WS_CHILD = &H40000000
     Public CONST WS_MINIMIZE = &H20000000
     Public CONST WS_VISIBLE = &H10000000
     Public CONST WS_DISABLED = &H8000000
     Public CONST WS_CLIPSIBLINGS = &H4000000
     Public CONST WS_CLIPCHILDREN = &H2000000
     Public CONST WS_MAXIMIZE = &H1000000
     Public CONST WS_CAPTION = &HC00000                  '  WS_BORDER Or WS_DLGFRAME
     Public CONST WS_BORDER = &H800000
     Public CONST WS_DLGFRAME = &H400000
     Public CONST WS_VSCROLL = &H200000
     Public CONST WS_HSCROLL = &H100000
     Public CONST WS_SYSMENU = &H80000
     Public CONST WS_THICKFRAME = &H40000
     Public CONST WS_GROUP = &H20000
     Public CONST WS_TABSTOP = &H10000
     Public CONST WS_MINIMIZEBOX = &H20000
     Public CONST WS_MAXIMIZEBOX = &H10000
     Public CONST WS_TILED = WS_OVERLAPPED
     Public CONST WS_ICONIC = WS_MINIMIZE
     Public CONST WS_SIZEBOX = WS_THICKFRAME
     Public CONST WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED OR WS_CAPTION OR WS_SYSMENU OR WS_THICKFRAME OR WS_MINIMIZEBOX OR WS_MAXIMIZEBOX)
     Public CONST WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
     Public CONST WM_SETFONT = &H30

     DECLARE FUNCTION CreateWindowEx LIB "USER32" ALIAS "CreateWindowExA" _
      (ExStyle&, ClassName$, WindowName$, Style&, X&, Y&, _
      Width&, Height&, WndParent&, hMenu&, hInstance&, Param&) AS LONG
     DECLARE FUNCTION GetModuleHandle LIB "KERNEL32" ALIAS "GetModuleHandleA" _
      (ModuleName AS STRING) AS LONG
     DECLARE FUNCTION SetWindowText LIB "USER32" ALIAS "SetWindowTextA" _
      (Hwnd AS INTEGER, Text AS STRING) AS LONG
     DECLARE FUNCTION MoveWindow LIB "USER32" ALIAS "MoveWindow" ( hwdn&, X&, Y&, Width&, Height&, refresh&) AS LONG
     DECLARE FUNCTION xSendMessage LIB "user32" ALIAS "SendMessageA" (hwnd AS INTEGER, wmsg AS INTEGER, wparam AS INTEGER, lparam AS LONG) AS LONG
     DECLARE FUNCTION LoadCursor LIB "USER32" ALIAS "LoadCursorA" (hinst AS LONG, hcursor AS LONG) AS LONG
     DECLARE FUNCTION SetCursor LIB "USER32" ALIAS "SetCursor" (hcursor AS LONG) AS LONG
     DECLARE FUNCTION ShowCursor LIB "USER32" ALIAS "ShowCursor" (xbool AS INTEGER) AS LONG
'
     TYPE LV_ITEM
      mask AS INTEGER
      iItem AS INTEGER
      iSubItem AS INTEGER
      state AS INTEGER
      stateMask AS INTEGER
      pszText AS LONG
      cchTextMax AS INTEGER
      iImage AS INTEGER
      lParam AS LONG
     END TYPE

     TYPE LV_COLUMN
      mask AS INTEGER
      fmt AS INTEGER
      cx AS INTEGER
      pszText AS LONG
      cchTextMax AS INTEGER
      iSubItem AS INTEGER
     END TYPE

'/****************************************************************************/
     DECLARE SUB BROWINIT
     DECLARE SUB GetFile(Sender AS QBUTTON)
'DECLARE SUB DBBROWINFO(Sender AS QBUTTON)
     DECLARE SUB DBROWEND(Sender AS QBUTTON)
     DECLARE SUB MainSize(Sender AS QFORM)
     DECLARE SUB MainPaint(Sender AS QFORM)
'/****************************************************************************/
     DIM hTable AS LONG, dbfname AS STRING, dbrw AS LONG
'
     DIM dfont AS QFONT
     dFont.Charset=238
     dFont.Name="Arial"
     dFont.Size=8
     dFont.AddStyles(fsBold)

     DIM cfont AS QFONT
     cFont.Charset=238
     cFont.Name="Courier New"
     cFont.Size=8
     cFont.AddStyles(fsBold)

     CREATE DBrow AS QFORM
      CAPTION = "XBase file browser"
      Width=600
      Height=420
      Font = dfont
      OnReSize = MainSize
      OnPaint = MainPaint
      Center
      CREATE dadd AS QBUTTON
       CAPTION = "&Get File"
       Left = 4
       Top = 366
       Height=24
       Width=60
       TabOrder = 2
       OnClick = GetFile
      END CREATE
      CREATE dend AS QBUTTON
       CAPTION = "E&xit"
       Left = 530
       Top = 366
       Height=24
       Width=60
       TabOrder = 6
       OnClick = DBrowEnd
      END CREATE
     END CREATE
     dbrw=CreateWindowEx(512,"SysListView32","", 4 OR 8 OR 1 OR WS_CHILD OR WS_TABSTOP OR WS_VISIBLE, _
      2,4,584,358,DBrow.Handle, 201, GetModuleHandle("XBROW.EXE"),0)
     SendMessage(dbrw, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, LVEX_FULLROWSELECT OR LVEX_HEADERDRAGDROP  OR 1)
     SendMessage(dbrw, WM_SETFONT, cFont.Handle, 1 )
'
     dbfname=""
     htable=0
     AdsSetServerType(1)
     IF COMMANDCOUNT > 0 THEN
      dbfname=COMMAND$(1)
      IF FILEEXISTS(dbfname) THEN
       BROWINIT
      ELSE
       MESSAGEBOX("File "+dbfname+" does not exit !","Error !",48)
      END IF
     ELSE
      GetFile(dadd)
     END IF
     DBrow.SHOWMODAL
     END
'/****************************************************************************/
     SUB BROWINIT()
      DIM ulRetVal AS LONG, i AS INTEGER, t AS INTEGER, bEof AS INTEGER, ulNumRecs AS LONG, usCount AS INTEGER, ctmp AS STRING, ulFldLen AS LONG , ulRec AS LONG
      DIM lvcol AS LV_COLUMN, lvi AS LV_ITEM, uiFldType AS INTEGER, hcsr AS LONG, ocsr AS LONG
'
      hTable=0
      DBrow.Cursor = crHourGlass
      ulRetVal=xSendMessage(dbrw, &H1000+28, 0, 0)
      WHILE ulRetVal<>0
       ulRetVal=xSendMessage(dbrw, &H1000+28, 0, 0)
      WEND
      SendMessage(dbrw, &H1000+9, 0, 0)
      ulRetVal = AdsOpenTable( 0, dbfname, "DBFILE", ADS_NTX, ADS_ANSI, ADS_COMPATIBLE_LOCKING, ADS_CHECKRIGHTS, ADS_DEFAULT, @hTable )
      IF ulRetVal <> AE_SUCCESS THEN
       AdsShowError("ADS Couldn't open table" )
       EXIT SUB
      END IF
      AdsGetRecordCount( hTable, ADS_IGNOREFILTERS, @ulNumRecs )
      AdsGetNumFields( hTable, @usCount )
'
      DIM aFldN(usCount) AS STRING
      DIM aFldT(usCount) AS INTEGER
      DIM aFldL(uscount) AS INTEGER
      lvcol.mask=LVCF_FMT OR LVCF_WIDTH OR LVCF_TEXT OR LVCF_SUBITEM
      FOR t=1 TO usCount
       ctmp=SPACE$(512)
       i=512
       AdsGetFieldName(hTable, t, @ctmp, @i)
       ctmp=LEFT$(ctmp, i)
       aFldN(t)=ctmp
       AdsGetFieldLength(hTable, ctmp, @ulFldLen)
       aFldL(t)=ulFldLen
       AdsGetFieldType(htable, @ctmp, @uiFldType)
       aFldT(t)=uiFldType
   '
       SELECT CASE aFldT(t)
       CASE ADS_CURDOUBLE
        lvcol.fmt = 1
       CASE ADS_SHORTINT
        lvcol.fmt = 1
       CASE ADS_INTEGER
        lvcol.fmt = 1
       CASE ADS_DOUBLE
        lvcol.fmt = 1
       CASE ADS_NUMERIC
        lvcol.fmt = 1
       CASE ELSE
        lvcol.fmt = 0
       END SELECT
       lvcol.cx = ulFldLen *10
       lvcol.pszText=VARPTR(ctmp)
       lvcol.iSubItem=t-1
       SendMessage(dbrw, &H1000+27, t-1, @lvcol)
      NEXT
      AdsGotoTop(hTable)
      AdsAtEOF(hTable, @bEof )
      WHILE bEof=0
       AdsGetRecordNum(hTable, ADS_IGNOREFILTERS, @ulRec)
       ctmp=SPACE$(256)
       i=256
       AdsGetField(hTable, aFldn(1), @ctmp,  @i, ADS_TRIM)
       lvi.mask=1
       lvi.state=0
       lvi.stateMask=0
       lvi.iImage=0
       lvi.iSubItem=0
       lvi.iItem=ulRec-1
       lvi.pszText=VARPTR(ctmp)
       lvi.cchTextMax=LEN(ctmp)
       SendMessage(dbrw, &H1000+7, 0, @lvi)
   '
       FOR t=2 TO usCount
        ctmp=SPACE$(256)
        i=256
        AdsGetField(hTable, aFldN(t), @ctmp,  @i, ADS_TRIM)
        lvi.iSubItem=t-1
        lvi.pszText=VARPTR(ctmp)
        SendMessage(dbrw, &H1000+46, ulRec-1, @lvi)
       NEXT
       AdsSkip(hTable, 1)
       AdsAtEOF( hTable, @bEof )
      WEND
      AdsGotoTop(hTable)
      DBrow.CAPTION="XBase file browser "+dbfname
      DBrow.Cursor = crDefault
     END SUB
'/****************************************************************************/
     SUB GETFILE
      DIM od AS QOPENDIALOG
'
      od.CAPTION="Select a XBASE file to Browse"
      od.Filter="XBase files|*.dbf|"
      od.FilterIndex=1
      IF od.EXECUTE THEN
       IF hTable<>0 THEN
        AdsCloseTable(hTable)
        hTable=0
       END IF
       dbfname=od.Filename
       BROWINIT()
      END IF
     END SUB
'/****************************************************************************/
     SUB DBROWEND
      AdsCloseTable(hTable)
      hTable=0
      DBrow.CLOSE
     END SUB
'/****************************************************************************/
     SUB MainPaint (Sender AS QFORM)
      Sender.Line(0,Sender.Height-66,Sender.Width,Sender.Height-66,0)
      Sender.Line(0,Sender.Height-65,Sender.Width,Sender.Height-65,&HFFFFFF)
     END SUB
'/****************************************************************************/
     SUB MainSize(Sender AS QFORM)
      MoveWindow(dbrw, 2, 4, Sender.Width -12, Sender.Height - 76, 1)
      MoveWindow(dadd.Handle, 4, Sender.Height-58, 60,24, 1)
      MoveWindow(dend.Handle, Sender.Width-70, Sender.Height-58, 60,24, 1)
     END SUB
掌柜推荐
 
 
 
 
 
 
 
 
 
 
 
 
© Fri 2024-3-29  Guidance Laboratory Inc.
Email:webmaster1g.yi.org Hits:0 Last modified:2003-02-24 13:44:04