home *** CD-ROM | disk | FTP | other *** search
/ BUG 4 / BUGCD1997_05.BIN / aplic / clip4win / clip4win.exe / C4W30E.HUF / SOURCE / DEMOMULT.PRG < prev    next >
Text File  |  1994-06-13  |  68KB  |  2,127 lines
  1. /*
  2.  
  3.    Program: DEMO.PRG
  4.    Purpose: Multi-window demonstration of a Clipper 5.0 application
  5.             written to run under Microsoft Windows (with Clip-4-Win)
  6.    Authors: John Skelton and Greg Lief
  7.    Date:    November and December 1992
  8.  
  9.    Use "RMAKE DEMOMULT" to compile and link.
  10.  
  11.    This demo is Copyright (c) 1992 by John Skelton and Greg Lief.
  12.  
  13.    Clip-4-Win is Copyright (c) 1992 by John Skelton.
  14.  
  15.    The NTXREC() and NTXPOS() functions are based on Rick Spence's book,
  16.    were written in Microsoft C, and are provided by kind courtesy of
  17.    Graham McKechnie @ RCM Software Pty. Ltd.  At the very least, Robert
  18.    DiFalco and Don Caton have also contributed.  These functions make
  19.    use of an internal function entitled _ntxhandle(), which was written
  20.    in Assembler by Ted Means.  John Skelton has further modified them.
  21.  
  22.    NOTE: NTXREC() and NTXPOS() are NOT part of Clip-4-Win.  They're
  23.          just being used as a convenience.  Remember the warnings about
  24.          free software: you don't get many guarantees!  Please don't
  25.          expect them to work with e.g. CDX files -- they're called
  26.          NTX* for good reasons!
  27.  
  28.    Clip-4-Win is available from the following sources:
  29.  
  30.    *** North America, South America, Asia, and Australia ***
  31.    (as well as contact point for dealers/resellers in those areas)
  32.  
  33.    Grumpfish, Inc.
  34.    2450 Lancaster Drive, NE
  35.    Salem, Oregon 97305
  36.    USA
  37.    Tel: +1 (503) 588-1815
  38.    (USA Toll-free 800-367-7613)
  39.    Fax: +1 (503) 588-1980
  40.    BBS: +1 (503) 588-7572
  41.    CompuServe: 71064,2543
  42.  
  43.    *** United Kingdom ***
  44.     
  45.    QBS Software Ltd.
  46.    10 Barley Mow Passage
  47.    London  W4 4PH
  48.    UK
  49.    Tel: +44 81 994 4842
  50.    Fax: +44 81 994 3441
  51.    BBS: +44 81 747 1979
  52.    CompuServe: 100016,573
  53.  
  54.    *** Germany ***
  55.  
  56.    dc Soft GmbH
  57.    Machtlfinger Str. 26
  58.    D-81379 München
  59.    Germany
  60.    Tel: +49 89 78 58 910
  61.    Fax: +49 89 78 58 91 11
  62.    CompuServe: 100016,1673
  63.  
  64.    or:
  65.  
  66.    Tobax Software GmbH
  67.    Sudermanstrasse 12
  68.    D-50670 Köln
  69.    Germany
  70.    Tel: +49 221 738028
  71.    Fax: +49 221 722806
  72.    CompuServe: 100113,1131
  73.  
  74.    *** Scandinavia ***
  75.  
  76.    xLib Programs AB
  77.    Finnbodavägen 29
  78.    S-131 31  NACKA
  79.    Sweden
  80.    Tel: +46 8 644 31 06
  81.    Fax: +46 8 640 61 17
  82.    CompuServe: 73354,3430
  83.  
  84.    *** Belgium ***
  85.  
  86.    Belgian (Clipper) User Group
  87.    Moerkerkse Steenweg 322
  88.    B-8310 BRUGGE 3
  89.    Belgium
  90.    Tel: +32 50 35 78 66
  91.    Fax: +32 50 37 25 05
  92.    CompuServe: 100034,56
  93.  
  94.    *** Spain ***
  95.  
  96.    Danysoft Internacional
  97.    Paseo de Albacete, 73
  98.    28700 San Sebastian de los Reyes
  99.    Madrid
  100.    Spain
  101.    Tel: +34 1 654 62 98
  102.    Fax: +34 1 654 63 82
  103.    BBS: +34 1 653 41 13
  104.    CompuServe: 71774,1614
  105.  
  106.    *** France ***
  107.  
  108.    Aco-ProDucTionS
  109.    101, rue de la Justice
  110.    91800 Boussy-Saint-Antoine
  111.    France
  112.    Tel: +33 1 69 00 60 72
  113.    Fax: +33 1 69 00 57 33
  114.    CompuServe: 100272,2511
  115.  
  116.    PC Tech
  117.    24 rue Davoust
  118.    93500 Pantin
  119.    France
  120.    Tel: +33 1 49 42 96 24
  121.    Fax: +33 1 49 42 03 10
  122.    CompuServe: 70012,2313
  123.  
  124.    *** Italy ***
  125.  
  126.    SixBase srl
  127.    Via Giotto 30
  128.    20145 Milano
  129.    Italy
  130.    Tel: +39 2 4819 5421
  131.    Fax: +39 2 4801 3348
  132.    BBS: +39 2 4813 213
  133.    CompuServe: 100023,2415
  134.  
  135.    Italian Software Agency srl
  136.    Via Torino, 2
  137.    28042 Baveno (NO)
  138.    Italy
  139.    Tel: +39 323 922066
  140.    Fax: +39 323 925208
  141.    BBS: +39 323 925428
  142.  
  143.    *** Netherlands ***
  144.  
  145.    DSA Software BV
  146.    Kanaalweg 33
  147.    2903 LR Capelle aan den Ussel
  148.    Holland
  149.    Tel: +31 10 458 05 15
  150.    Fax: +31 10 458 25 01 or +31 10 442 45 18
  151.    BBS: +31 10 451 71 70
  152.    CompuServe: 100330,1162
  153.  
  154.    Lemax Company BV
  155.    Schipholweg 335 A
  156.    1171 PL Badhoevedorp
  157.    Holland
  158.    Tel: +31 20 659 8701
  159.    Fax: +31 20 659 6856
  160.    Fax Info-Service: +31 20 659 7196
  161.    BBS: +31 3483 4072 and 4335
  162.    CompuServe: 100012,1760
  163.  
  164.    *** Israel ***
  165.  
  166.    RDB Systems
  167.    18 Rival St.
  168.    Tel Aviv 67778
  169.    Israel
  170.    Tel: 972 3 639 0055
  171.    Fax: 972 3 639 0054
  172.    CompuServe: 100274,1440 or 100274,600
  173.    (including support for Hebrew Windows)
  174.  
  175.    *** "Arabic areas" ***
  176.  
  177.    Please contact Skelton Software
  178.    (support for Arabic Windows does exist!)
  179.  
  180.    *** Australia ***
  181.  
  182.    Aeronaut Industries
  183.    500 Miller Street
  184.    Cammeray  NSW 2062
  185.    Australia
  186.    Tel: +61 2 957 3127
  187.    Fax: +61 954 3049
  188.    Fax Info-Service: +61 964 9542
  189.    CompuServe: 100033,734
  190.  
  191.    or:
  192.  
  193.    RCM Software Pty. Ltd.
  194.    1198 Toorak Road
  195.    Hartwell, Vic 3124
  196.    Australia
  197.    Tel: +61 3 889 0580
  198.    Fax: +61 3 889 0263
  199.    BBS: +61 3 889 0397
  200.    CompuServe: 73467,1645
  201.  
  202.    *** Bulgaria ***
  203.  
  204.    Great Bear Technology Bulgaria Inc.
  205.    58 Kosta Lulchev Str.
  206.    1574 Sofia
  207.    Bulgaria
  208.    Tel: +359 2 700 120
  209.    Fax: +359 2 738 460
  210.  
  211.    *** Contact point for distributors ***
  212.  
  213.    Skelton Software
  214.    Kendal Cottage
  215.    Hillam
  216.    Leeds  LS25 5HP
  217.    ENGLAND
  218.    Tel: +44 977 683 296
  219.    Fax: +44 977 681 650
  220.    CompuServe: 100112,3102
  221.  
  222. */
  223.  
  224. external descend  // for index files that might need it
  225.  
  226. //───── necessary in the event of pushbutton movement on data entry screen
  227. //───── (see WREADER.PRG for complete structure of get:cargo array)
  228. #define FORCE_FOCUS   6
  229.  
  230. //───── this one handles fields
  231. #xcommand @ <row>, <col> SAY <prompt> GET [FIELD] <fname>        ;
  232.                          IN WINDOW <w>                    ;
  233.                          [GETROW <grow>]                ;
  234.                          [GETCOL <gcol>]                ;
  235.                          [PICTURE <pic>]                ;
  236.                          [BUTTONS <buttons>]                ;
  237.                          [VALID <valid>]                ;
  238.                          [WHEN <when>]                    ;
  239.                          [SAYCOLOR <saycolor>]                ;
  240.                          [GETCOLOR <getcolor>]                ;
  241.                                     ;
  242.       => AAdd( GetList, GetNew( <grow>, <gcol>, fieldblock(<fname>),    ;
  243.                                 <"fname">, <pic>, <getcolor> )        ;
  244.              )                                ;
  245.       ; ATail(GetList):reader := { | g, ev | WGetReader(g, ev, <w>,    ;
  246.                             getlist,            ;
  247.                                           <buttons>, BUTTON_HEIGHT )    ;
  248.                                  }                    ;
  249.       ; ATail(GetList):cargo := {                    ;
  250.                   NIL , <prompt>, <row>, <col>, <saycolor>, .f., .f.    ;
  251.                                 }                    ;
  252.       [; ATail(GetList):postBlock := <{valid}>]                ;
  253.       [; ATail(GetList):preBlock := <{when}>]
  254.  
  255. //───── this one handles variables
  256. #xcommand @ <row>, <col> SAY <prompt> GET <var>                ;
  257.                          IN WINDOW <w>                    ;
  258.                          REDRAW WITH <redraw>                ;
  259.                          [GETROW <grow>]                ;
  260.                          [GETCOL <gcol>]                ;
  261.                          [PICTURE <pic>]                ;
  262.                          [BUTTONS <buttons>]                ;
  263.                          [VALID <valid>]                ;
  264.                          [WHEN <when>]                    ;
  265.                          [SAYCOLOR <saycolor>]                ;
  266.                          [GETCOLOR <getcolor>]                ;
  267.                                     ;
  268.       => AAdd( GetList, GetNew( <grow>, <gcol>,                ;
  269.                { | _1 | if(_1 == NIL, <var>, <var> := _1) }, <(var)>,    ;
  270.                <pic>, <getcolor> )                    ;
  271.              )                                ;
  272.       ; ATail(GetList):reader := { | g, ev | WGetReader(g, ev, <w>,    ;
  273.                             getlist,            ;
  274.                                           <buttons>, BUTTON_HEIGHT )    ;
  275.                                  }                    ;
  276.       ; ATail(GetList):cargo := {                    ;
  277.                   NIL , <prompt>, <row>, <col>, <saycolor>, .f., .f.    ;
  278.                                 }                    ;
  279.       [; ATail(GetList):postBlock := <{valid}>]                ;
  280.       [; ATail(GetList):preBlock := <{when}>]
  281.  
  282. #xtranslate StripPath( <f> ) => ;
  283.            if("\" $ <f>, substr(<f>, rat("\", <f>) + 1), <f>)
  284.  
  285. #xtranslate StripExt( <fname> ) => ;
  286.       if('.' $ <fname>, substr( <fname>, 1, at('.', <fname>) - 1), <fname> )
  287.  
  288. //───── if you have "Sound Explosion", uncomment the following statement
  289. //───── and make sure that WAVE_DIRECTORY points to the directory where
  290. //───── your Sound Explosion .WAV files reside
  291. // #define SOUND_EXPLOSION
  292. #define WAVE_DIRECTORY  "C:\WINDOWS\"
  293.  
  294. #define WIN_WANT_CLIPBOARD  // to make Clipboard directives accessible
  295. #define WIN_WANT_LBS        // to make Listbox styles accessible
  296. #define WIN_WANT_ALL
  297.  
  298. #include "dbstruct.ch"
  299. #include "directry.ch"
  300. #include "error.ch"
  301. #include "getexit.ch"
  302. #include "inkey.ch"
  303. #include "windows.ch"
  304. #include "setcaret.ch"
  305. #include "font.ch"
  306.  
  307. #define    CR    chr(13)
  308.  
  309. //───── remove this if you do not want push buttons on data entry screen
  310. #define BUTTONS
  311.  
  312. //───── manifest constants for GetClientRect() and GetDIBRect() arrays
  313. //───── note that since Top and Left are always 0, they are unused
  314. #define W_RIGHT  3
  315. #define W_BOTTOM 4
  316.  
  317. //───── manifest constants for RGB() color combinations
  318. #define C_RED        RGB(255,0,0)
  319. #define C_BLUE       RGB(0,0,255)
  320. #define C_GREEN      RGB(0,255,0)
  321. #define C_MAGENTA    RGB(255,0,255)
  322. #define C_BLACK      RGB(0,0,0)
  323.  
  324. #define    TB_HEIGHT    30
  325. #define    ID_TOOLBAR    1000
  326. #define    ID_CLIENT    1001
  327.  
  328. #define APP_NAME     "Clip-4-Win"
  329.  
  330.  
  331. static hFrameWnd     // top-most (frame) window
  332. static hWnd          // main (client) window... must be visible in several places
  333. static cText := ""   // text in main window if a file is opened... must be
  334.                      // visible in several places for cut/copy to Clipboard
  335. static cDIB          // handle for bitmapped logo in main window... must be
  336.                      // visible in several places for copying to Clipboard
  337. static nMainEvId     // ID of main event handler... visible throughout
  338.                      // because it must be reset periodically
  339.  
  340.  
  341. /*
  342.    Function: Main()
  343. */
  344. function main
  345. local hMenu, nEvent, hCurrWnd, hTBWnd, aRect
  346. set scoreboard off     // don't even THINK about using it in Windows!!
  347. hWnd := WinSetup(APP_NAME, "Clip-4-Win Demo")
  348. /*
  349.  *  Set up the outermost window as the frame window, with the "main"
  350.  *  window actually a child sized to fit the area left after the toolbar.
  351.  */
  352. hFrameWnd := hWnd
  353. hMenu := MenuSetup()
  354. HideCaret(hFrameWnd)
  355. hTBWnd := ToolbarSetup(hFrameWnd, hMenu)
  356. aRect := GetClientRect(hFrameWnd)
  357. hWnd := CreateWindow(APP_NAME, "", WS_CHILD + WS_VISIBLE, ;
  358.              0, TB_HEIGHT, aRect[W_RIGHT], aRect[W_BOTTOM] - TB_HEIGHT,;
  359.              hFrameWnd, ID_CLIENT)
  360. HideCaret(hWnd)
  361. AddHandler(hFrameWnd, {|nEvent| FrameEvent(nEvent, hTBWnd, hWnd)})
  362. nMainEvId := AddHandler(hWnd, {|nEvent| MainEvent(nEvent)})
  363. /*
  364.    The C4W_AutoClose() function allows us to make the user confirm their
  365.    decision to quit the app, even if they try to close the window
  366.    with ALT-F4 (or via the System menu).  It will cause the EVENT_CLOSE
  367.    event to be generated, which we can then react to (see below)
  368. */
  369. C4W_AutoClose(.f.)
  370.  
  371. /*
  372.  *  SetHandleCount() is needed to tell Windows how many file handles
  373.  *  this application uses (40 isn't true for this one!).
  374.  */
  375. SetHandleCount(40)
  376.  
  377. do while .t.
  378.    do while (nEvent := ChkEvent()) == EVENT_NONE
  379.       // "background" processing could go here
  380.    enddo
  381.    HandleEvent(nEvent)
  382.    do case
  383.    case nEvent == EVENT_CLOSE
  384.       //───── determine if main window is currently active
  385.       hCurrWnd := _LasthWnd()
  386.       if hWnd == hCurrWnd
  387.          DoExit()
  388.       else
  389.          DestroyWindow(hCurrWnd)
  390.          SetFocus(hWnd)
  391.       endif
  392.    case nEvent == EVENT_QUIT
  393.       quit
  394.    endcase
  395. enddo
  396. return nil
  397.  
  398.  
  399. /*
  400.    Function: ToolbarSetup()
  401. */
  402. static function ToolbarSetup(hWnd, hMenu)
  403. local    aButtons :=                            ;
  404. { {10, 3, 25, 22, ReadDIB("open1.bmp"), GetMenuId(hMenu, "open")},    ;
  405.   {60, 3, 25, 22, ReadDIB("print1.bmp"), GetMenuId(hMenu, "print")},    ;
  406.   {110, 3, 25, 22, ReadDIB("browse1.bmp"), GetMenuId(hMenu, "browse")},    ;
  407.   {160, 3, 25, 22, ReadDIB("exit1.bmp"), GetMenuId(hMenu, "exit")},    ;
  408.   {210, 3, 25, 22, ReadDIB("help1.bmp"), GetMenuId(hMenu, "about")} }
  409. local    aRect, hTBWnd
  410.  
  411. /*
  412.  *  This sample puts the toolbar at the top of the window's
  413.  *  client area.  A child window is created to fill the area
  414.  *  left.  The user doesn't know the "childclient" exists,
  415.  *  so just make it fill the area not used by the toolbar.  Of
  416.  *  course, this means changing its size if the main window changes
  417.  *  size (msg WM_SIZE).  The toolbar size needs to change as well
  418.  *  (just the width in this example).
  419.  *
  420.  *  This same technique can be useful at other times, e.g. the child
  421.  *  might be a multi-line edit control.
  422.  *
  423.  *  If you have a status bar, the easiest way to handle it is to
  424.  *  make it another window (with no special border, no title bar,
  425.  *  etc., and using WS_CHILD + WS_VISIBLE), put it at the bottom
  426.  *  of the frame window, and reduce the child client's window height
  427.  *  by the height of the status bar.
  428.  *  (Yes, you do get extra windows.  Don't worry.)
  429.  */
  430.  
  431. aRect = GetClientRect(hWnd)
  432. hTBWnd = ToolBar(hWnd, 0, 0, aRect[3], TB_HEIGHT, aButtons, ID_TOOLBAR)
  433. return hTBWnd
  434.  
  435.  
  436. /*
  437.    Function: FrameEvent()
  438. */
  439. static function FrameEvent(nEvent, hTBWnd, hWnd)
  440. local aRect, nW, nH
  441. do case
  442. case nEvent == EVENT_WINSIZE
  443.    aRect := GetClientRect(hFrameWnd)
  444.    nW := aRect[W_RIGHT]        // same as _LastLolParam()
  445.    nH := aRect[W_BOTTOM]    // same as _LastHilParam()
  446.    MoveWindow(hTBWnd, 0, 0, nW, TB_HEIGHT, .t.)
  447.    MoveWindow(hWnd, 0, TB_HEIGHT, nW, nH - TB_HEIGHT, .f.)
  448. endcase
  449. return nil
  450.  
  451.  
  452. /*
  453.    Function: MainEvent()
  454. */
  455. static function MainEvent(nEvent)
  456. local hDC
  457. local aDIBRect, aClientRect
  458. do case
  459. case nEvent == EVENT_REDRAW
  460.    hDC := GetDC(hWnd)
  461.    if cDIB == NIL
  462.       cDIB := ReadDIB("clip4win.bmp")
  463.    endif
  464.    aDIBRect := GetDIBRect(cDIB)
  465.    aClientRect := GetClientRect(hWnd)
  466.    // centre the bitmap
  467.    ShowDIB(hDC, cDIB, (aClientRect[W_RIGHT] - aDIBRect[W_RIGHT]) / 2, ;
  468.                       (aClientRect[W_BOTTOM] - aDIBRect[W_BOTTOM]) / 2)
  469.    ReleaseDC(hWnd, hDC)
  470. endcase
  471. return nil
  472.  
  473.  
  474. /*
  475.    Function: Credits()
  476. */
  477. static function credits
  478. MessageBox( , "By John Skelton and Greg Lief (rev 17-June-93)", ;
  479.               "About Clip-4-Win Demo", MB_ICONASTERISK + MB_OK)
  480. return nil
  481.  
  482.  
  483. /*
  484.    Function: DoExit()
  485. */
  486. static function DoExit()
  487. //───── Note that MessageBox() returns a value based on the I.D. of
  488. //───── the selected item, all of which have corresponding ID* manifest
  489. //───── constants in the WINDOWS.CH header file
  490. if MessageBox(0, "Are you sure you want to exit this demo?", ;
  491.          "Leaving so soon?", MB_OKCANCEL + MB_ICONQUESTION) == IDOK
  492.    if IsWindow(hWnd)
  493.       DestroyWindow(hWnd)
  494.    endif
  495.    UnregisterClass(APP_NAME)
  496.    quit
  497. endif
  498. return nil
  499.  
  500.  
  501. /*
  502.    Function: DoAudio()
  503.    Note:     If you have Sound Explosion, use it instead of the
  504.              somewhat feeble stock Windows .WAV files
  505. */
  506. static function DoAudio()
  507. #ifdef SOUND_EXPLOSION
  508.    static waves_ := { "WHISTLE1", "SCREAM5", "LAUGH4", "BELCH2" }
  509. #else
  510.    static waves_ := { "CHORD", "CHIMES", "TADA", "DING" }
  511. #endif
  512. local hLib, cSound, hWnd, n
  513. hLib   := LoadLibrary("MMSYSTEM.DLL")
  514. cSound := GetProcAddress(hLib, "SndPlaySound", "Pascal", "Int", "str, int")
  515.  
  516. //───── note that Alert() allows you to specify trigger letters by
  517. //───── preceding them with an ampersand
  518. #ifdef SOUND_EXPLOSION
  519.    n := alert("Pick a sound", ;
  520.           { "&Whistle", "&Scream", "&Laugh" } )
  521. #else
  522.    n := alert("Pick a sound", ;
  523.           { "&Chord", "Chi&mes", "&Tada" } )
  524. #endif
  525.  
  526. // if they escaped out, use sound #4
  527. if n == 0
  528.    n := 4
  529. endif
  530.  
  531. //───── second parameter to SndPlaySound() is: 1 == return instantly,
  532. //───── 0 == wait until finished playing before returning
  533.  
  534. n := CallDLL(cSound, WAVE_DIRECTORY + waves_[n] + ".WAV", 1)
  535. if n == 0
  536.    MessageBox(, "No audio hardware" + CR + "Or other error", ;
  537.           MB_ICONHAND + MB_OK)
  538. endif
  539. return nil
  540.  
  541.  
  542. /*
  543.    Function: DoColor()
  544. */
  545. static function DoColor()
  546. static  nX := 20, nY := 50
  547. local   nColor := ChooseColor(), hWnd
  548. if nColor >= 0         // else user chose cancel/close or hit Esc
  549.    hWnd := WinNew("Color", nX += 40, nY += 60, 150, 100)
  550.    AddHandler(hWnd, {|nEvent| ColorEvent(nEvent, hWnd, nColor)})
  551. endif
  552. return nil
  553.  
  554.  
  555. /*
  556.    Function: ColorEvent()
  557. */
  558. static function ColorEvent(nEvent, hWnd, nColor)
  559. local    hDC, hBrush
  560. do case
  561. case nEvent == EVENT_REDRAW
  562.    hDC := GetDC(hWnd)
  563.    hBrush := CreateSolidBrush(nColor)
  564.    FillRect(hDC, 20, 20, 100, 50, hBrush)
  565.    DeleteObject(hBrush)
  566.    ReleaseDC(hWnd, hDC)
  567. endcase
  568. return nil
  569.  
  570.  
  571. /*
  572.    Function: DoOpen()
  573. */
  574. static function DoOpen
  575. local cFile := GetOpenFileName(, "*.txt", "Select a text file")
  576. local hMenu
  577. if cFile <> NIL
  578.    if directory(cFile)[1][F_SIZE] < 65535
  579.       //───── because we want this text file to be displayed in the
  580.       //───── main window, we must first delete the primary event handler
  581.       DelHandler(nMainEvId)
  582.       cText := memoread(cFile)
  583.       nMainEvId := AddHandler(hWnd, ;
  584.               { | nEvent | CBEventText(nEvent, hWnd, cText)})
  585.  
  586.       //───── enable the "Clear" and "Cut" menu items ("Copy" already enabled)
  587.       hMenu := GetMenu(hFrameWnd)       // retrieve reference to main menu
  588.       EnableMenuItem(hMenu, "clear", MF_ENABLED)
  589.       EnableMenuItem(hMenu, "cut", MF_ENABLED)
  590.  
  591.       //───── force main window to be redrawn immediately
  592.       InvalidateRect(hWnd)
  593.    else
  594.      MessageBox(hWnd, cFile + " is too large to load", "Error", ;
  595.               MB_ICONEXCLAMATION + MB_OK)
  596.    endif
  597. endif
  598. return nil
  599.  
  600.  
  601. /*
  602.    Function: DaDoRunRun()
  603.    Note:     Long live Phil Spector!
  604. */
  605. static function DaDoRunRun
  606. local cFile := GetOpenFileName(, "*.exe;*.com;*.bat", "Run", ;
  607.                    { {"programs", "*.exe;*.com;*.bat"} } )
  608. local hCursor
  609. local hOldcursor
  610. if cFile <> NIL
  611.    hCursor := LoadCursor(, IDC_WAIT)
  612.    hOldcursor := SetCursor(hCursor)
  613.    WinExec(cFile)
  614.    SetCursor(hOldcursor)   // restore previous cursor
  615. endif
  616. return nil
  617.  
  618.  
  619. /*
  620.    Function: DoClear()
  621. */
  622. static function DoClear
  623. if MessageBox(hWnd, "Are you sure you want to clear the current text?", ;
  624.           "Question", MB_OKCANCEL + MB_ICONQUESTION) == IDOK
  625.    cText := ''
  626.    ResetMainEvent()
  627. endif
  628. return nil
  629.  
  630.  
  631. /*
  632.    Function: DoCutCopy()
  633. */
  634. static function DoCutCopy(c)
  635. if OpenClipboard(hWnd)
  636.    EmptyClipboard()
  637.    //───── if there is no text in the main window, copy the logo instead
  638.    if empty(cText)
  639.       SetClipboardData(CF_DIB, cDIB)
  640.    else
  641.       SetClipboardData(CF_TEXT, "*** Pasted From Clip-4-Win ***" + CR + cText)
  642.    endif
  643.    CloseClipboard()
  644.  
  645.    //───── if we just "cut", clear text and reset to show the logo
  646.    if c == "cut"
  647.       cText := ""
  648.       ResetMainEvent()
  649.    endif
  650. else
  651.    MessageBox( , "Clipboard not available", "Info", MB_ICONHAND + MB_OK)
  652. endif
  653. return nil
  654.  
  655.  
  656. /*
  657.    Function: DoPaste()
  658. */
  659. static function DoPaste()
  660. static  nX := 300, nY := 150
  661. local hWnd
  662. local cPasted
  663. if OpenClipboard(hWnd)
  664.  
  665.    //───── retrieve text from Clipboard
  666.    cPasted := GetClipbData(CF_TEXT)
  667.    //───── if Clipboard contained text, create new window to hold it
  668.    if ! empty(cPasted)
  669.       hWnd := WinNew("Text from Clipboard", nX += 40, nY += 40, 250, 150)
  670.       AddHandler(hWnd, { | nEvent | ;
  671.               CBEventText(nEvent, hWnd, cPasted)})
  672.    else  // Clipboard did not contain text -- maybe it contains a bitmap?
  673.       cPasted := GetClipbData(CF_DIB)
  674.       if ! empty(cPasted)
  675.          hWnd := WinNew("Bitmap from Clipboard", nX += 40, nY += 40, 250, 150)
  676.          AddHandler(hWnd, {|nEvent| CBEventDIB(nEvent, hWnd, cPasted)})
  677.       endif
  678.    endif
  679.    CloseClipboard()
  680.    if empty(cPasted)
  681.       MessageBox( , "Clipboard is either empty" + CR + ;
  682.             "or contains unknown data", "Info", MB_ICONHAND + MB_OK)
  683.    endif
  684. else
  685.    MessageBox( , "Clipboard not available", "Info", MB_ICONHAND + MB_OK)
  686. endif
  687. return nil
  688.  
  689.  
  690. /*
  691.    Function: CBEventText()
  692. */
  693. static function CBEventText(nEvent, hWnd, cText)
  694. local hDC
  695. do case
  696. case nEvent == EVENT_REDRAW
  697.    hDC := GetDC(hWnd)
  698.    DrawText(hDC, cText, GetClientRect(hWnd))
  699.    ReleaseDC(hWnd, hDC)
  700. endcase
  701. return nil
  702.  
  703.  
  704. /*
  705.    Function: CBEventDIB()
  706. */
  707. static function CBEventDIB(nEvent, hWnd, cDIB)
  708. local hDC
  709. do case
  710. case nEvent == EVENT_REDRAW
  711.    hDC := GetDC(hWnd)
  712.    ShowDIB(hDC, cDIB, 0, 0)
  713.    ReleaseDC(hWnd, hDC)
  714. endcase
  715. return nil
  716.  
  717.  
  718. /*
  719.    Function: DoDLL()
  720. */
  721. static function DoDLL()
  722. static    nX := 20, nY := 200
  723. local    hLib, cRectangle, hWnd
  724. hLib := LoadLibrary("GDI.EXE")
  725. cRectangle := GetProcAddress(hLib, "rectangle", "Pascal", "Int", ;
  726.                  "int, int, int, int, int")
  727. hWnd := WinNew("DLL", nX += 40, nY += 60, 200, 100)
  728. AddHandler(hWnd, {|nEvent| DLLEvent(nEvent, hWnd, cRectangle)})
  729. return nil
  730.  
  731.  
  732. /*
  733.    Function: DLLEvent()
  734. */
  735. static function DLLEvent(nEvent, hWnd, cRectangle)
  736. local    hDC, cText
  737. do case
  738. case nEvent == EVENT_REDRAW
  739.    hDC := GetDC(hWnd)
  740.    cText := "CallDLL(Rectangle, ...) --> " + ;
  741.          nstr(CallDLL(cRectangle, hDC, 10, 30, 100, 50))
  742.    DrawText(hDC, cText, GetClientRect(hWnd))
  743.    ReleaseDC(hWnd, hDC)
  744. case nEvent == EVENT_LCLICK .or. nEvent == EVENT_RCLICK
  745.    InvalidateRect(hWnd)
  746. endcase
  747. return nil
  748.  
  749.  
  750. /*
  751.    Function: DoFont()
  752. */
  753. static function DoFont()
  754. static  nX := 100, nY := 50
  755. local   aFont := {40, 40, 450, 0, 400, .t., .f., .f., 1, 0, 0, 0, 0, "Arial"}
  756. local   hWnd, nColor := C_RED
  757. aFont := ChooseFont(aFont, , , @nColor)
  758. if aFont <> NIL         // else user chose cancel/close or hit Esc
  759.    hWnd := WinNew("Font", nX += 40, nY += 60, 300, 200)
  760.    AddHandler(hWnd, {|nEvent| FontEvent(nEvent, hWnd, aFont, nColor)})
  761. endif
  762. return nil
  763.  
  764.  
  765. /*
  766.    Function: FontEvent()
  767. */
  768. static function FontEvent(nEvent, hWnd, aFont, nColor)
  769. local   hDC, hFont, hOldFont, i, j
  770. static msg := "Clip-4-Win"
  771. static  aShow := { {200, 200, 300},  ;     // {x coord, y coord, angle}
  772.            {0,  350, 1800},  ;     // angle is in 3600 gradiants
  773.            {10, 200,  800},  ;     // e.g., 900 points straight up
  774.            {20, 0,   2700},  ;     // 0 is horizontal left-to-right
  775.            {75, 400, 1350},  ;
  776.            {100, 20, 0},     ;
  777.            {100, 300, 450},  ;
  778.            {125, 425, 450},  ;     // 1800 is horizontal right-to-left
  779.            {200, 50, 3450},  ;
  780.            {250, 200, 0},    ;
  781.            {300, 15, 2100},  ;
  782.            {300,400, 1080},  ;
  783.            {375,200, 300},   ;
  784.            {470,300, 2700},  ;
  785.            {500,200, 1800},  ;
  786.            {550,100, 3500},  ;
  787.            {400, 50, 3150} }
  788. do case
  789. case nEvent == EVENT_REDRAW
  790.    hDC := GetDC(hWnd)
  791.    SetTextColor(hDC, nColor)
  792.    j := len(aShow)
  793.    for i := 1 to j
  794.       aFont[LF_Escapement] := aShow[i, 3]
  795.       hFont := CreateFont(aFont)
  796.       hOldFont := SelectObject(hDC, hFont)
  797.       TextOut(hDC, aShow[i, 1], aShow[i, 2], msg)
  798.       //───── note that SelectObject() returns a handle to the
  799.       //───── prior object, so you can delete it in one fell swoop
  800.       DeleteObject( SelectObject(hDC, hOldFont) )
  801.    next
  802.    ReleaseDC(hWnd, hDC)
  803. endcase
  804. return nil
  805.  
  806.  
  807. /*
  808.    Function: DoPie()
  809. */
  810. static function DoPie()
  811. static  nX := 400, nY := 50
  812. local   hWnd := WinNew("Pie", nX += 40, nY += 60, 100, 100)
  813. AddHandler(hWnd, {|nEvent| PieEvent(nEvent, hWnd)})
  814. return nil
  815.  
  816.  
  817. /*
  818.    Function: PieEvent()
  819. */
  820. static function PieEvent(nEvent, hWnd)
  821. local hDC, aRect, hBrush, hOldbrush
  822. do case
  823. case nEvent == EVENT_REDRAW
  824.    hBrush := CreateSolidBrush(C_RED)
  825.    aRect := GetClientRect(hWnd)
  826.    hDC := GetDC(hWnd)
  827.    hOldbrush := SelectObject(hDC, hBrush)
  828.    pie(hDC, 0, 0, aRect[W_RIGHT], aRect[W_BOTTOM], ;
  829.         aRect[W_RIGHT] / 2, 0, aRect[W_RIGHT], aRect[W_BOTTOM])
  830.    hBrush := CreateSolidBrush(C_MAGENTA)
  831.    //───── Just as it is important to close each open file handle, you
  832.    //───── should always delete each object when you are done with it.
  833.    //───── Note that this can be done with the following syntax, which
  834.    //───── lets you re-use the same variable name for multiple objects.
  835.    DeleteObject( SelectObject(hDC, hBrush) )
  836.  
  837.    pie(hDC, 0, 0, aRect[W_RIGHT], aRect[W_BOTTOM], aRect[W_RIGHT], ;
  838.         aRect[W_BOTTOM], aRect[W_RIGHT] * .75, aRect[W_BOTTOM] * .25)
  839.    hBrush := CreateSolidBrush(C_BLUE)
  840.    DeleteObject( SelectObject(hDC, hBrush) )
  841.    pie(hDC, 0, 0, aRect[W_RIGHT], aRect[W_BOTTOM], aRect[W_RIGHT], ;
  842.         aRect[W_BOTTOM] / 2, aRect[W_RIGHT] * .75, aRect[W_BOTTOM] * .25)
  843.    hBrush := CreateSolidBrush(C_GREEN)
  844.    DeleteObject( SelectObject(hDC, hBrush) )
  845.    pie(hDC, 0, 0, aRect[W_RIGHT], aRect[W_BOTTOM], ;
  846.        aRect[W_RIGHT] * .75, aRect[W_BOTTOM] * .25, aRect[W_RIGHT] / 2, 0)
  847.    DeleteObject( SelectObject(hDC, hOldbrush) )
  848.    ReleaseDC(hWnd, hDC)
  849. endcase
  850. return nil
  851.  
  852.  
  853. /*
  854.    Function: DoBar()
  855. */
  856. static function DoBar()
  857. static  nX := 150, nY := 175
  858. local hWnd := WinNew("Bar Graph", nX += 40, nY += 60, 250, 125)
  859. AddHandler(hWnd, {|nEvent| BarEvent(nEvent, hWnd)})
  860. return nil
  861.  
  862.  
  863. /*
  864.    Function: BarEvent()
  865. */
  866. static function BarEvent(nEvent, hWnd)
  867. local hDC, aRect, hBrush, hOldbrush, nWidth
  868. do case
  869. case nEvent == EVENT_REDRAW
  870.    hBrush := CreateHatchBrush(HS_BDIAGONAL, C_RED)
  871.    aRect := GetClientRect(hWnd)
  872.    nWidth := aRect[W_RIGHT] / 6
  873.    hDC := GetDC(hWnd)
  874.    hOldbrush := SelectObject(hDC, hBrush)
  875.    TextOut(hDC, nWidth + 10, aRect[W_BOTTOM] * .15 - 20, "U.S.A.")
  876.    rectangle(hDC, nWidth, aRect[W_BOTTOM] * .15, ;
  877.           nWidth * 2, aRect[W_BOTTOM])
  878.    hBrush := CreateHatchBrush(HS_VERTICAL, C_MAGENTA)
  879.    DeleteObject( SelectObject(hDC, hBrush) )
  880.    TextOut(hDC, nWidth * 2 + 10, aRect[W_BOTTOM] * .4 - 20, "England")
  881.    rectangle(hDC, nWidth * 2, aRect[W_BOTTOM] * .4, ;
  882.           nWidth * 3, aRect[W_BOTTOM])
  883.    hBrush := CreateHatchBrush(HS_FDIAGONAL, C_BLUE)
  884.    DeleteObject( SelectObject(hDC, hBrush) )
  885.    TextOut(hDC, nWidth * 3 + 10, aRect[W_BOTTOM] * .8 - 20, "Australia")
  886.    rectangle(hDC, nWidth * 3, aRect[W_BOTTOM] * .8, ;
  887.           nWidth * 4, aRect[W_BOTTOM])
  888.    hBrush := CreateHatchBrush(HS_CROSS, C_GREEN)
  889.    DeleteObject( SelectObject(hDC, hBrush) )
  890.    TextOut(hDC, nWidth * 4 + 10, aRect[W_BOTTOM] * .55 - 20, "Germany")
  891.    rectangle(hDC, nWidth * 4, aRect[W_BOTTOM] * .55, ;
  892.           nWidth * 5, aRect[W_BOTTOM])
  893.    DeleteObject( SelectObject(hDC, hOldbrush) )
  894.    ReleaseDC(hWnd, hDC)
  895. endcase
  896. return nil
  897.  
  898.  
  899. /*
  900.    Function: DoPrint()
  901. */
  902. static function DoPrint()
  903. local hPrintDC, hIcon, hBrush, hOldBrush, hCursor, hOldCursor
  904. local nBlack := C_BLACK
  905. local i, nWidth, nHeight
  906.  
  907. // display printer dialog box, so the user can choose the settings
  908. hPrintDC := GetPrintDC()
  909. if empty(hPrintDC)
  910.    // cancelled by the user
  911.    return nil
  912. endif
  913.  
  914. // print a test page
  915.  
  916. hCursor := LoadCursor( , IDC_WAIT)
  917. hOldCursor := SetCursor(hCursor)
  918.  
  919. nWidth := GetDeviceCaps(hPrintDC, HORZRES)
  920. nHeight := GetDeviceCaps(hPrintDC, VERTRES)
  921.  
  922. StartDoc(hPrintDC, "TestOutput")
  923. StartPage(hPrintDC)
  924.  
  925. TextOut(hPrintDC, 100, 50, "Clip-4-Win Printer Test Page")
  926. Rectangle(hPrintDC, 0, 0, nWidth, nHeight)
  927. MoveTo(hPrintDC, 0, 0)
  928. LineTo(hPrintDC, nWidth, nHeight)
  929. MoveTo(hPrintDC, nWidth, 0)
  930. LineTo(hPrintDC, 0, nHeight)
  931.  
  932. Arc(hPrintDC,   1000, 1000,   1300, 1200,   1250, 1190,   1100, 1100)
  933.  
  934. hBrush := CreateHatchBrush(HS_HORIZONTAL, nBlack)
  935. hOldBrush := SelectObject(hPrintDC, hBrush)
  936. Chord(hPrintDC, 1500, 1200,   2000, 1350,   1550, 1340,   1400, 1200)
  937. DeleteObject( SelectObject(hPrintDC, hOldBrush) )
  938.  
  939. hBrush := CreateHatchBrush(HS_BDIAGONAL, nBlack)
  940. hOldBrush := SelectObject(hPrintDC, hBrush)
  941. Pie(hPrintDC,   100, 1200,   700, 1500,   650, 1490,   120, 1280)
  942. DeleteObject( SelectObject(hPrintDC, hOldBrush) )
  943.  
  944. hBrush := CreateHatchBrush(HS_FDIAGONAL, nBlack)
  945. hOldBrush := SelectObject(hPrintDC, hBrush)
  946. Polygon(hPrintDC, { {1000, 250}, {1600, 500}, {1800, 100} })
  947. DeleteObject( SelectObject(hPrintDC, hOldBrush) )
  948. PolyLine(hPrintDC, { {300, 700}, {100, 900}, {500, 1000} })
  949. for i := 100 to 500 step 100
  950.    TextOut(hPrintDC, i + 400, i + 100, nstr(i))
  951. next i
  952. EndPage(hPrintDC)
  953. EndDoc(hPrintDC)
  954. DeleteDC(hPrintDC)
  955. SetCursor(hOldCursor)
  956. return nil
  957.  
  958.  
  959. /*
  960.    Function: DoTimer()
  961. */
  962. static function DoTimer()
  963. static  lTimer := .F., hWnd
  964. if ! lTimer
  965.    hWnd := WinNew("Timer", 400, 150, 135, 75)
  966.    SetTimer(hWnd, 1, 1000)     // every 1000 millisecs (= one second)
  967.    lTimer := .T.
  968.    AddHandler(hWnd, ;
  969.           {|nEvent| TimerEvent(nEvent, hWnd, @lTimer)})
  970. endif
  971. return nil
  972.  
  973.  
  974. /*
  975.    Function: TimerEvent()
  976. */
  977. static function TimerEvent(nEvent, hWnd, lTimer)
  978. local hDC, hFont, hOldFont, aRect
  979. static aFont := { -55, -17, 0, 0, FW_SEMIBOLD, .F., .F., .F., 0, 3, 2, 1, 18, ;
  980.           "Times New Roman" }
  981. do case
  982. case nEvent == EVENT_TIMER
  983.    InvalidateRect(hWnd)
  984. case nEvent == EVENT_CLOSE .or. nEvent == EVENT_DESTROY
  985.    if IsWindow(hWnd)
  986.       KillTimer(hWnd, 1)
  987.       DestroyWindow(hWnd)
  988.    endif
  989.    lTimer := .F.
  990. case nEvent == EVENT_WINSIZE
  991.    //───── adjust font height/width based on new size of this window
  992.    aRect := GetClientRect(hWnd)
  993.    aFont[LF_Height] := - aRect[W_BOTTOM] * .85
  994.    aFont[LF_Width] := - aRect[W_RIGHT] * .11
  995.  
  996. case nEvent == EVENT_REDRAW
  997.    hDC := GetDC(hWnd)
  998.    SetTextColor(hDC, C_BLUE)
  999.    hFont := CreateFont(aFont)
  1000.    hOldFont := SelectObject(hDC, hFont)
  1001.    DrawText(hDC, time(), GetClientRect(hWnd))
  1002.    DeleteObject( SelectObject(hDC, hOldFont) )
  1003.    ReleaseDC(hWnd, hDC)
  1004. endcase
  1005. return nil
  1006.  
  1007.  
  1008. /*
  1009.    Function: NStr()
  1010. */
  1011. static function nstr(n)
  1012. return alltrim(str(n)) + " "
  1013.  
  1014.  
  1015. /*
  1016.    Function: asString()
  1017. */
  1018. static function asString(x)
  1019. local    v := valtype(x)
  1020. do case
  1021.    case v == "C"
  1022.    case v == "N"
  1023.       return nstr(x)
  1024.    case v == "L"
  1025.       if x
  1026.          return ".T."
  1027.       else
  1028.          return ".F."
  1029.       endif
  1030.    case v == "D"
  1031.       return "date"
  1032.    case v == "U"
  1033.       return "NIL"
  1034.    case v $ "AOB"
  1035.       return ""
  1036.    otherwise
  1037.       return ""
  1038. end case
  1039. return x
  1040.  
  1041.  
  1042. /*
  1043.    Function: MenuSetup()
  1044. */
  1045. static function MenuSetup()
  1046. local hWnd := SelectWindow()
  1047. local hMenu
  1048. local hPopupMenu
  1049.  
  1050. if (hMenu := GetMenu(hWnd)) <> NIL
  1051.    DestroyMenu(hMenu)
  1052. endif
  1053.  
  1054. //───── note the grayed out entries (search for MF_GRAYED)
  1055. //───── also note that ampersand indicates the trigger letter
  1056. hMenu := CreateMenu()
  1057. hPopupMenu := CreatePopupMenu()
  1058. AppendMenu(hMenu, "file", MF_ENABLED + MF_POPUP, "&File", hPopupMenu)
  1059. AppendMenu(hPopupMenu, "open", MF_ENABLED + MF_STRING, "&Open...", {|| DoOpen()})
  1060. AppendMenu(hPopupMenu, "clear", MF_GRAYED + MF_STRING, "&Clear", {|| DoClear()})
  1061. AppendMenu(hPopupMenu, "run", MF_ENABLED + MF_STRING, "&Run...", {|| DaDoRunRun()})
  1062. AppendMenu(hPopupMenu, "save", MF_GRAYED + MF_STRING, "&Save", {|| qout("save")})
  1063. AppendMenu(hPopupMenu, "saveas", MF_GRAYED + MF_STRING, "Save &As...", {|| qout("save as")})
  1064. AppendMenu(hPopupMenu, "", MF_SEPARATOR)
  1065. AppendMenu(hPopupMenu, "print", MF_ENABLED + MF_STRING, "&Print...", {|| DoPrint()})
  1066. AppendMenu(hPopupMenu, "", MF_SEPARATOR)
  1067. AppendMenu(hPopupMenu, "exit", MF_ENABLED + MF_STRING, "E&xit", {|| DoExit() })
  1068.  
  1069. hPopupMenu := CreatePopupMenu()
  1070. AppendMenu(hMenu, "edit", MF_ENABLED + MF_POPUP, "&Edit", hPopupMenu)
  1071. AppendMenu(hPopupMenu, "cut", MF_GRAYED + MF_STRING, "Cu&t", {|c| DoCutCopy(c)})
  1072. AppendMenu(hPopupMenu, "copy", MF_ENABLED + MF_STRING, "&Copy", {|c| DoCutCopy(c)})
  1073. AppendMenu(hPopupMenu, "paste", MF_ENABLED + MF_STRING, "&Paste", {|| DoPaste()})
  1074. AppendMenu(hPopupMenu, "", MF_SEPARATOR)
  1075. AppendMenu(hPopupMenu, "toggle", MF_ENABLED + MF_STRING, "&Toggle", {|c| ToggleItem(c) })
  1076. AppendMenu(hPopupMenu, "find", MF_GRAYED + MF_STRING, "&Find...", {|c| qout(c)})
  1077. AppendMenu(hPopupMenu, "replace", MF_GRAYED + MF_STRING, "&Replace...", {|c| qout(c)})
  1078.  
  1079. hPopupMenu := CreatePopupMenu()
  1080. AppendMenu(hMenu, "stuff1", MF_ENABLED + MF_POPUP, "&Stuff", hPopupMenu)
  1081. AppendMenu(hPopupMenu, "color", MF_ENABLED + MF_STRING, "&Color...", {|c| DoColor()})
  1082. AppendMenu(hPopupMenu, "dll", MF_ENABLED + MF_STRING, "&DLL", {|c| DoDLL()})
  1083. AppendMenu(hPopupMenu, "font", MF_ENABLED + MF_STRING, "&Font...", {|c| DoFont()})
  1084. AppendMenu(hPopupMenu, "", MF_SEPARATOR)
  1085. AppendMenu(hPopupMenu, "pie chart", MF_ENABLED + MF_STRING, "&Pie Chart", {|c| DoPie()})
  1086. AppendMenu(hPopupMenu, "bar graph", MF_ENABLED + MF_STRING, "&Bar Graph", {|c| DoBar()})
  1087.  
  1088. hPopupMenu := CreatePopupMenu()
  1089. AppendMenu(hMenu, "stuff2", MF_ENABLED + MF_POPUP, "&More Stuff", hPopupMenu)
  1090. AppendMenu(hPopupMenu, "audio", MF_ENABLED + MF_STRING, "&Audio...", {|c| DoAudio()})
  1091. AppendMenu(hPopupMenu, "cursor", MF_ENABLED + MF_STRING, "&Cursor", {|c| DoCursor()})
  1092. AppendMenu(hPopupMenu, "icons", MF_ENABLED + MF_STRING, "&Icons", {|c| DoIcons()})
  1093. AppendMenu(hPopupMenu, "printer", MF_ENABLED + MF_STRING, "&Printer...", {|c| DoPrint()})
  1094. AppendMenu(hPopupMenu, "timer", MF_ENABLED + MF_STRING, "&Timer", {|c| DoTimer()})
  1095.  
  1096. hPopupMenu := CreatePopupMenu()
  1097. AppendMenu(hMenu, "dataentry", MF_ENABLED + MF_POPUP, "&Data Entry", hPopupMenu)
  1098. AppendMenu(hPopupMenu, "modelessgets", MF_ENABLED + MF_STRING, "&Modeless", {|| ModelessGets()})
  1099. AppendMenu(hPopupMenu, "valtest", MF_ENABLED + MF_STRING, "&Validation", {|| ValidTest()})
  1100.  
  1101. hPopupMenu := CreatePopupMenu()
  1102. AppendMenu(hMenu, "browsemenu", MF_ENABLED + MF_POPUP, "&Browses", hPopupMenu)
  1103. AppendMenu(hPopupMenu, "browse", MF_ENABLED + MF_STRING, "&Browse...", {|| DoBrowse()})
  1104.  
  1105. hPopupMenu := CreatePopupMenu()
  1106. AppendMenu(hMenu, "help", MF_ENABLED + MF_POPUP, "&Help", hPopupMenu)
  1107. AppendMenu(hPopupMenu, "about", MF_ENABLED + MF_STRING, "&About", {|| credits()})
  1108. SetMenu(hWnd, hMenu)
  1109. return hMenu
  1110.  
  1111.  
  1112. /*
  1113.    Function: DoCursor()
  1114. */
  1115. static function DoCursor()
  1116. static cursors_ := { IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, ;
  1117.              IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, ;
  1118.              IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS }
  1119. local y := len(cursors_)
  1120. local x
  1121. local hCursor
  1122. local hOldcursor := SetCursor()
  1123. MessageBox(hWnd, "Press spacebar to cycle through the stock cursors", "Info", ;
  1124.          MB_OK)
  1125. for x := 1 to y
  1126.    hCursor := LoadCursor( , cursors_[x])
  1127.    if hCursor <> 0
  1128.       SetCursor(hCursor)
  1129.    endif
  1130.    inkey(3)
  1131. next
  1132. SetCursor(hOldcursor)
  1133. return nil
  1134.  
  1135.  
  1136.  
  1137. /*
  1138.    Function: DoIcons()
  1139. */
  1140. static function DoIcons()
  1141. static  nX := 250, nY := 100
  1142. local hWnd := WinNew("Icons", nX += 40, nY += 60, 300, 100)
  1143. AddHandler(hWnd, {|nEvent| IconEvent(nEvent, hWnd)})
  1144. return nil
  1145.  
  1146.  
  1147. /*
  1148.    Function: IconEvent()
  1149. */
  1150. static function IconEvent(nEvent, hWnd)
  1151. static icons_ := { IDI_EXCLAMATION, IDI_HAND, IDI_ASTERISK, ;
  1152.            IDI_QUESTION, IDI_APPLICATION }
  1153. local hDC
  1154. local x
  1155. local hIcon
  1156. local aRect
  1157. do case
  1158. case nEvent == EVENT_REDRAW
  1159.    aRect := GetClientRect(hWnd)
  1160.    hDC := GetDC(hWnd)
  1161.    if hDC <> 0
  1162.       for x := 1 to 5
  1163.          if ( hIcon := LoadIcon(, icons_[x]) ) <> 0
  1164.             DrawIcon(hDC, aRect[W_RIGHT] * x / 6, ;
  1165.                           aRect[W_BOTTOM] * .4, hIcon)
  1166.          endif
  1167.       next
  1168.       ReleaseDC(hWnd, hDC)
  1169.    endif
  1170. endcase
  1171. return nil
  1172.  
  1173.  
  1174. /*
  1175.    Function: ModelessGets()
  1176. */
  1177. static function ModelessGets
  1178. local cFile
  1179. local getlist := {}
  1180. local x
  1181. local f
  1182. local nFields
  1183. local hCWnd
  1184. local nHand
  1185. local nArea
  1186. local nOldarea := select()
  1187. local bOldinsert
  1188. #ifdef BUTTONS
  1189.    local nWidth
  1190.    local aRect
  1191.    local nY
  1192.    local hInst
  1193.    local lContinue := .t.
  1194.    local aButtons := {}
  1195.    local nButton
  1196. #endif
  1197. cFile := GetOpenFileName(, "*.dbf", "Select a database")
  1198. if cFile <> NIL
  1199.    if select(StripPath(StripExt(cFile))) == 0
  1200.       use (cFile) new
  1201.    else
  1202.       // trying to browse/edit a dbf that's already open
  1203.  
  1204.       // the following would probably just confuse
  1205.       //dbSelectArea(StripPath(StripExt(cFile)))
  1206.       MessageBox( , "Already in use", "Error", MB_ICONHAND + MB_OK)
  1207.       return nil
  1208.    endif
  1209.    x := alias()
  1210.  
  1211.    //───── I realize that this is not particularly graceful, but the
  1212.    //───── purpose of this demo is not necessarily to show locking
  1213.    //───── techniques... i.e., puh-leeze feel free to substitute your own!
  1214.    if ! rlock()
  1215.       MessageBox(, "Cannot edit " + x + " database at this time", ;
  1216.            MB_ICONHAND + MB_OK)
  1217.       dbSelectArea(nOldarea)
  1218.       return nil
  1219.    endif
  1220.  
  1221.    // the WS_CLIPCHILDREN makes sure anything drawn with WS_CHILD is visible
  1222.    // (e.g. the buttons)
  1223.    hCWnd := WinNew("Editing " + left(x, 1) + lower(substr(x, 2)) + ;
  1224.            " Database", 0, 0, 350, 250,            ;
  1225.            WS_OVERLAPPEDWINDOW + WS_CLIPCHILDREN)
  1226.    #ifdef BUTTONS
  1227.  
  1228.    #define BUTTON_HEIGHT  20
  1229.    #define B_NEXT   1
  1230.    #define B_PREV   2
  1231.    #define B_FIRST  3
  1232.    #define B_LAST   4
  1233.    #define B_ADD    5
  1234.  
  1235.    #define TOTAL_BUTTONS  5
  1236.  
  1237.    aRect := GetClientRect(hCWnd)
  1238.    hInst := _GetInstance()
  1239.    nWidth := aRect[W_RIGHT] / TOTAL_BUTTONS
  1240.    nY := aRect[W_BOTTOM] - BUTTON_HEIGHT
  1241.    aadd(aButtons, CreateWindow("button",         ;       // button class name
  1242.                                "Next",           ;       // title text
  1243.                                WS_CHILD          ;       // child window
  1244.                                + WS_VISIBLE      ;       // ... that can be seen
  1245.                                + BS_PUSHBUTTON,  ;       // ... a push button
  1246.                                0, nY,            ;       // x,y position
  1247.                                nWidth,           ;       // width
  1248.                                BUTTON_HEIGHT,    ;       // height
  1249.                                hCWnd,            ;       // parent window
  1250.                                B_NEXT,           ;       // unique child id
  1251.                                hInst)  )                 // parent's instance
  1252.  
  1253.    aadd(aButtons, CreateWindow("button",         ;       // button class name
  1254.                                "Prev",           ;       // title text
  1255.                                WS_CHILD          ;       // child window
  1256.                                + WS_VISIBLE      ;       // ... that can be seen
  1257.                                + BS_PUSHBUTTON,  ;       // ... a push button
  1258.                                nWidth, nY,       ;       // x,y position
  1259.                                nWidth,           ;       // width
  1260.                                BUTTON_HEIGHT,    ;       // height
  1261.                                hCWnd,            ;       // parent window
  1262.                                B_PREV,           ;       // unique child id
  1263.                                hInst)   )                // parent's instance
  1264.  
  1265.    aadd(aButtons, CreateWindow("button",         ;       // button class name
  1266.                                "First",          ;       // title text
  1267.                                WS_CHILD          ;       // child window
  1268.                                + WS_VISIBLE      ;       // ... that can be seen
  1269.                                + BS_PUSHBUTTON,  ;       // ... a push button
  1270.                                nWidth*2, nY,     ;       // x,y position
  1271.                                nWidth,           ;       // width
  1272.                                BUTTON_HEIGHT,    ;       // height
  1273.                                hCWnd,            ;       // parent window
  1274.                                B_FIRST,          ;       // unique child id
  1275.                                hInst)   )                // parent's instance
  1276.  
  1277.    aadd(aButtons, CreateWindow("button",         ;       // button class name
  1278.                                "Last",           ;       // title text
  1279.                                WS_CHILD          ;       // child window
  1280.                                + WS_VISIBLE      ;       // ... that can be seen
  1281.                                + BS_PUSHBUTTON,  ;       // ... a push button
  1282.                                nWidth*3, nY,     ;       // x,y position
  1283.                                nWidth,           ;       // width
  1284.                                BUTTON_HEIGHT,    ;       // height
  1285.                                hCWnd,            ;       // parent window
  1286.                                B_LAST,           ;       // unique child id
  1287.                                hInst)   )                // parent's instance
  1288.  
  1289.    aadd(aButtons, CreateWindow("button",         ;       // button class name
  1290.                                "Add",            ;       // title text
  1291.                                WS_CHILD          ;       // child window
  1292.                                + WS_VISIBLE      ;       // ... that can be seen
  1293.                                + BS_PUSHBUTTON,  ;       // ... a push button
  1294.                                nWidth*4, nY,     ;       // x,y position
  1295.                                nWidth,           ;       // width
  1296.                                BUTTON_HEIGHT,    ;       // height
  1297.                                hCWnd,            ;       // parent window
  1298.                                B_ADD,            ;       // unique child id
  1299.                                hInst)   )                // parent's instance
  1300.  
  1301.    #endif
  1302.  
  1303.    //───── create Getlist array and load it with GET objects
  1304.    nFields := fcount()
  1305.    for x := 1 to nFields
  1306.       f := field(x)
  1307.       #ifdef BUTTONS
  1308.          @ x, 2 say lower(f) get field f in window hCWnd buttons aButtons ;
  1309.                              picture '@K' saycolor 'n/w' getcolor 'n/bg,+w/b'
  1310.       #else
  1311.          @ x, 2 say lower(f) get field f in window hCWnd picture '@K' ;
  1312.                              saycolor 'n/w' getcolor 'n/bg,+w/b'
  1313.       #endif
  1314.    next
  1315.  
  1316.    ShowCaret(hCWnd)
  1317.  
  1318. //   EnableMenuItem(GetMenu(hFrameWnd), "modelessgets", MF_GRAYED)  // one at a time
  1319.    nArea := select()
  1320. #ifdef BUTTONS
  1321.    nHand := AddHandler(hCWnd, {|nEvent| ModelessEvent(GetList, nEvent, hCWnd, nHand, nArea, aButtons)})
  1322. #else
  1323.    nHand := AddHandler(hCWnd, {|nEvent| ModelessEvent(GetList, nEvent, hCWnd, nHand, nArea, {})})
  1324. #endif // BUTTONS
  1325. endif
  1326.  
  1327. dbSelectArea(nOldarea)
  1328. return nil
  1329.  
  1330.  
  1331. /*
  1332.    Procedure: ModelessEvent()
  1333. */
  1334. static procedure ModelessEvent(GetList, nEvent, hCWnd, nHand, nArea, aButtons)
  1335. local    nButton, hOldWnd, nOldArea := select()
  1336.  
  1337. select (nArea)
  1338. if nEvent == EVENT_DESTROY .and. used()
  1339.     close
  1340. endif
  1341.  
  1342. if ReadModeless(GetList, nEvent) == NIL
  1343.     // not yet finished the read
  1344.     select (nOldArea)
  1345.     return                // wait for next event
  1346. endif
  1347. // getting here means the read has completed
  1348.  
  1349. #ifdef BUTTONS
  1350. // maybe a button was pressed
  1351. if nEvent == EVENT_CONTROL
  1352.          nButton := _lastwParam()
  1353.          do case
  1354.             case nButton == B_NEXT
  1355.                dbskip(1)
  1356.                if eof()
  1357.                   MessageBox( , "You are at the end of the file", ;
  1358.                                 "Message", MB_ICONHAND + MB_OK)
  1359.                   dbgobottom()
  1360.                endif
  1361.             case nButton == B_PREV
  1362.                dbskip(-1)
  1363.                if bof()
  1364.                   MessageBox( , "You are at the start of the file", ;
  1365.                              "Message", MB_ICONHAND + MB_OK)
  1366.                   dbgotop()
  1367.                endif
  1368.             case nButton == B_FIRST
  1369.                dbgotop()
  1370.             case nButton == B_LAST
  1371.                dbgobottom()
  1372.             case nButton == B_ADD
  1373.                dbappend()
  1374.          endcase
  1375.      hOldWnd = SelectWindow(hCWnd)
  1376.          //───── as we may have changed records, redisplay all GETs
  1377.          aeval(getlist, { | g | g:display() } )
  1378.          //───── force first GET to gain focus immediately upon
  1379.          //───── entering WGetReader() (see notes in WREADER.PRG)
  1380.          getlist[1]:cargo[FORCE_FOCUS] := .t.
  1381.          //───── give this window focus again because one of the buttons might
  1382.          //───── still have it (which would force all keystrokes to be ignored!)
  1383.          SetFocus(hCWnd)
  1384.          // restart the GETs
  1385.          ReadModeless(GetList, EVENT_NONE)    // output the GETs
  1386.      SelectWindow(hOldWnd)
  1387.          select (nOldArea)
  1388.          return                // wait for next event
  1389. endif
  1390. #endif // BUTTONS
  1391.  
  1392. // getting here means the read has completed (or been abandoned)
  1393.  
  1394. if used()
  1395.     close
  1396. endif
  1397. select (nOldArea)                    
  1398. if nEvent == EVENT_DESTROY
  1399.     // abandoned
  1400.     return
  1401. endif
  1402.  
  1403. HideCaret(hCWnd)
  1404. DestroyWindow(hCWnd)
  1405. // the following is not needed, as the buttons are all children of hWnd
  1406. // and are thus cleaned up automatically...
  1407. //aeval(aButtons, { | b | DestroyWindow(b) } )
  1408. DelHandler(nHand)
  1409. EnableMenuItem(GetMenu(hFrameWnd), "modelessgets", MF_ENABLED)
  1410. return
  1411.  
  1412.  
  1413. /*
  1414.    Function: DoBrowse()
  1415. */
  1416. static function DoBrowse
  1417. static nX := 10, nY := 10
  1418. local b
  1419. local hWnd
  1420. local x
  1421. local f
  1422. local c
  1423. local e
  1424. local nFields
  1425. local fields_
  1426. local cFile
  1427. local cNtxfile
  1428. local bOldhandler
  1429. local nArea
  1430. static lFirsttime
  1431. cFile := GetOpenFileName(, "*.dbf", "Select a database")
  1432. if cFile <> NIL
  1433.    if select(StripPath(StripExt(cFile))) == 0
  1434.       cNtxfile := GetOpenFileName(, "*.ntx", "Select an index file")
  1435.       use (cFile) new shared
  1436.       if cNtxfile != nil .and. !(".ntx" $ lower(cNtxfile))
  1437.          // you can't use ntxpos()/ntxrec(), and may well need to be
  1438.          // using a different RDD (this is a sample, not the browser from hell!)
  1439.          MessageBox( , "Index ignored - only NTX supported", APP_NAME, MB_ICONSTOP)
  1440.          cNtxfile := nil
  1441.       endif
  1442.       if cNtxfile <> NIL
  1443.          bOldhandler := errorblock( { | e | bogusindex(e, bOldhandler) } )
  1444.          dbsetindex(cNtxfile)
  1445.          //───── verify the validity of this index key
  1446.          begin sequence
  1447.             x := eval( &("{ || " + indexkey(0) + "}") )
  1448.          recover using e
  1449.             MessageBox(, "Invalid index (missing " + e:operation + " "  + ;
  1450.              if(e:genCode == EG_NOVAR, "field", "") +      ;
  1451.              if(e:genCode == EG_NOFUNC, "function", "") +      ;
  1452.              if(e:genCode == EG_NOALIAS, "alias", "") +      ;
  1453.              ")" + CR + "Browsing " + StripPath(cFile) +      ;
  1454.              " in natural order", "Bogus Index",          ;
  1455.              MB_ICONHAND + MB_OK)
  1456.             dbclearindex()
  1457.          end sequence
  1458.          errorblock(bOldhandler)
  1459.       endif
  1460.    else
  1461.       // trying to browse a dbf that's already open
  1462.  
  1463.       // the following would probably just confuse
  1464.       //dbSelectArea(StripPath(StripExt(cFile)))
  1465.       MessageBox( , "Already in use", "Error", MB_ICONHAND + MB_OK)
  1466.       return nil
  1467.    endif
  1468.    x := alias()
  1469.    hWnd := WinNew("Browsing " + left(x, 1) + lower(substr(x, 2)) + ;
  1470.                   " Database", nX += 20, nY += 20, 525, 200, ;
  1471.                   WS_OVERLAPPEDWINDOW + WS_VSCROLL + WS_HSCROLL)
  1472.    b := TBrowseDB(0, 0, maxrow(), maxcol())
  1473.    b:headSep := "─┬─"
  1474.    b:colSep  := " │ "
  1475.    b:colorSpec := "+w/b, +gr/n, +w/r, +r/w"
  1476.  
  1477.    nFields := fcount()
  1478.  
  1479.    #define B_FIELDNAMES    1
  1480.    #define B_RECNO         2
  1481.    #define B_ALIAS         3
  1482.    #define B_CARGO_LEN     3
  1483.  
  1484.    b:cargo := array(B_CARGO_LEN)
  1485.  
  1486.    //───── we are going to store an array of fieldnames in the TBrowse
  1487.    //───── cargo instance variable (to be used when inserting new columns)
  1488.    b:cargo[B_FIELDNAMES] := array(nFields)
  1489.    b:cargo[B_RECNO] := recno()     // record pointer for this browse window
  1490.    b:cargo[B_ALIAS] := alias()     // needed when editing specific cells
  1491.    fields_ := dbstruct()
  1492.    for x := 1 to nFields
  1493.       b:cargo[B_FIELDNAMES][x] := field(x)
  1494.  
  1495.       //───── memos must be treated differently than "regular" fields
  1496.       if fields_[x][DBS_TYPE] == "M"
  1497.          c := TBColumnNew(b:cargo[B_FIELDNAMES][x], &("{ || if(empty(" + ;
  1498.                           b:cargo[B_FIELDNAMES][x] + "), '<memo>', '<MEMO>') }"))
  1499.          c:cargo := { || ShowMemo(b) }
  1500.       else
  1501.          c := TBColumnNew(b:cargo[B_FIELDNAMES][x], fieldwblock(b:cargo[B_FIELDNAMES][x], select()))
  1502.       endif
  1503.  
  1504.       //───── set color block to highlight negative numbers
  1505.       //───── dumb example, I know, but it will have to do for now...
  1506.       if valtype(eval(c:block)) == "N"
  1507.          c:colorBlock := { | x | if( x < 0, { 3, 4 }, { 1, 2 } ) }
  1508.       endif
  1509.  
  1510.       b:AddColumn(c)
  1511.    next
  1512.  
  1513.    //───── set range of horizontal scrollbar to match # of columns
  1514.    //───── note that if you later decide to add or delete columns,
  1515.    //───── you should do this again to set the new range
  1516.    SetScrollRange(hWnd, SB_HORZ, 1, b:colCount, .f.)
  1517.  
  1518.    nArea := select()
  1519.    lFirsttime := .t.
  1520.    AddHandler(hWnd, {|nEvent| BrowseEvent(nEvent, hWnd, nArea, b, @lFirsttime)})
  1521.    //InvalidateRect(hWnd)
  1522. endif
  1523. return nil
  1524.  
  1525.  
  1526. /*
  1527.    Function: BogusIndex()
  1528.    Purpose:  To catch any errors due to invalid indexes
  1529. */
  1530. static function bogusindex(oError, bOldhandler)
  1531. if oError:genCode == EG_NOFUNC        ;
  1532.    .or. oError:genCode == EG_NOVAR    ;
  1533.    .or. oError:genCode == EG_NOALIAS
  1534.    break oError
  1535. endif
  1536. return eval(bOldhandler, oError)
  1537.  
  1538.  
  1539. /*
  1540.    Function: BrowseEvent()
  1541. */
  1542. static function BrowseEvent(nEvent, hWnd, nArea, b, lFirsttime)
  1543. local nKey
  1544. local nColumn
  1545. local nWidth
  1546. local nTemprow
  1547. local nTopclear
  1548. local nBottomclear
  1549. local x
  1550. local hCursor
  1551. local hOldcursor
  1552. local hOldWnd := SelectWindow(hWnd)
  1553. local nScrollcmd
  1554. local nNewrec
  1555. local nOldrec
  1556. local nSkipcnt
  1557. local oColumn
  1558. local nOldArea := select()
  1559.  
  1560. //───── note: these statics should eventually be encapsulated within
  1561. //─────       the appropriate TBrowse object
  1562. static lKeypressed := .f.
  1563. static lWait := .f.
  1564. static nHPos := 1
  1565. static nVPos := 0
  1566. //──────────────────────────────────────────────────────────────────
  1567.  
  1568. select (nArea)
  1569. do case
  1570.    case nEvent == EVENT_DESTROY .and. used()
  1571.       close
  1572.    //───── if the browse window has just regained focus, force a
  1573.    //───── refresh because it is possible that the user has edited
  1574.    //───── data on this screen elsewhere (e.g. via "Data Entry" option)
  1575.    //───── NOTE: could be reworked with the PostMessage() function...
  1576.    case nEvent == EVENT_SETFOCUS .and. ! lFirsttime
  1577.       InvalidateRect(hWnd)
  1578.       //───── move record pointer to previously saved position if necessary
  1579.       if recno() <> b:cargo[B_RECNO]
  1580.          dbgoto(b:cargo[B_RECNO])
  1581.       endif
  1582.       b:refreshAll()
  1583.  
  1584.    case nEvent == EVENT_KILLFOCUS
  1585.       b:cargo[B_RECNO] := recno()
  1586.  
  1587.    case nEvent == EVENT_REDRAW
  1588.       if ! lKeypressed
  1589.          //───── try to determine the minimum number of rows that
  1590.          //───── must be redisplayed... much faster than refreshAll()!
  1591.          if ! lFirsttime
  1592.             nTopclear := _RedrawTop() - 1
  1593.             //───── if any part of the column header and/or heading
  1594.             //───── separator were zapped, we must refreshAll()!
  1595.             if nTopclear < if(! empty(b:headSep), 2, 1)
  1596.                b:refreshAll()
  1597.                lWait := .t.
  1598.             else
  1599.                nBottomclear := _RedrawBottom() - 1
  1600.                nTemprow := b:rowPos
  1601.                for x := nTopclear to nBottomclear
  1602.                   b:rowPos := x
  1603.                   b:refreshCurrent()
  1604.                next
  1605.                b:rowPos := nTemprow
  1606.             endif
  1607.          else
  1608.             lFirsttime := .f.
  1609.             b:refreshAll()
  1610.             lWait := .t.
  1611.          endif
  1612.       else
  1613.          lKeypressed := .f.
  1614.       endif
  1615.       if lWait
  1616.          //───── a refreshAll() is somewhat time-consuming,
  1617.          //───── so we will switch to the hourglass cursor
  1618.          hCursor := LoadCursor(, IDC_WAIT)
  1619.          hOldcursor := SetCursor(hCursor)
  1620.          lWait := .f.
  1621.       endif
  1622.       do while ! b:stabilize()
  1623.       enddo
  1624.       if hOldcursor <> NIL
  1625.          SetCursor(hOldcursor)   // restore previous cursor
  1626.       endif
  1627.       UpdateScrollbar(hWnd, b, @nVPos, @nHPos)
  1628.  
  1629.    case nEvent == EVENT_KEY
  1630.       nKey := inkey(0)
  1631.       lKeypressed := .t.
  1632.       do case
  1633.          case nKey == K_UP
  1634.             b:up()
  1635.          case nKey == K_DOWN
  1636.             b:down()
  1637.          case nKey == K_PGUP
  1638.             b:pageUp()
  1639.          case nKey == K_PGDN
  1640.             b:pageDown()
  1641.          case nKey == K_CTRL_PGUP
  1642.             b:goTop()
  1643.          case nKey == K_CTRL_PGDN
  1644.             b:goBottom()
  1645.          case nKey == K_LEFT
  1646.             b:left()
  1647.          case nKey == K_RIGHT
  1648.             b:right()
  1649.          case nKey == K_ENTER
  1650.             if editcell(b, hWnd)
  1651.                if b:getColumn(b:colPos):heading $ upper(indexkey(0))
  1652.                   b:refreshAll()
  1653.                   lKeypressed := .f.
  1654.                   lWait := .t.
  1655.                else
  1656.                   b:refreshCurrent()
  1657.                endif
  1658.             endif
  1659.  
  1660.          case chr(nKey) == "+"            // expand current column
  1661.             oColumn := b:getColumn(b:colPos)
  1662.             if oColumn:width == NIL
  1663.                oColumn:width := b:colWidth(b:colPos)
  1664.             endif
  1665.             oColumn:width++
  1666.             b:configure()
  1667.  
  1668.          case chr(nKey) == "-"            // shrink current column
  1669.             oColumn := b:getColumn(b:colPos)
  1670.             if oColumn:width == NIL
  1671.                oColumn:width := b:colWidth(b:colPos)
  1672.             endif
  1673.             if oColumn:width > 1
  1674.                oColumn:width--
  1675.                b:configure()
  1676.             endif
  1677.  
  1678.          case nKey == K_INS               // insert new column
  1679.             if ! empty(x := pickfield(b))
  1680.                b:insColumn(b:colPos, TBColumnNew(x, fieldblock(x)))
  1681.  
  1682.                //───── must reset range of horizontal scrollbar to match
  1683.                //───── new number of columns
  1684.                SetScrollRange(hWnd, SB_HORZ, 1, b:colCount, .f.)
  1685.  
  1686.                //───── force horizontal scrollbar display to be updated
  1687.                //───── in UpdateScrollbar()
  1688.                nHPos := 0
  1689.             endif
  1690.  
  1691.          case nKey == K_DEL               // delete current column
  1692.             b:delColumn(b:colPos)
  1693.             //───── must reset range of horizontal scrollbar to match
  1694.             //───── new number of columns
  1695.             SetScrollRange(hWnd, SB_HORZ, 1, b:colCount, .f.)
  1696.             //───── force horizontal scrollbar display to be updated
  1697.             //───── in UpdateScrollbar()
  1698.             nHPos := 0
  1699.  
  1700.          case nKey == K_ESC
  1701.             lKeypressed := .f.
  1702.         DestroyWindow(hWnd)        // close the browse
  1703.  
  1704.          case nKey == K_ALT_F4
  1705.         // ignore (will close the browse)
  1706.             lKeypressed := .f.
  1707.  
  1708.          otherwise
  1709.             lKeypressed := .f.
  1710.             MessageBeep(MB_ICONEXCLAMATION)
  1711.       endcase
  1712.       if lKeypressed
  1713.          do while ! b:stabilize()
  1714.          enddo
  1715.          UpdateScrollbar(hWnd, b, @nVPos, @nHPos)
  1716.       endif
  1717.  
  1718.    case nEvent == EVENT_WINSIZE
  1719.       b:nBottom := maxrow()
  1720.       b:nRight := maxcol()
  1721.  
  1722.    case nEvent == EVENT_LDBLCLK     // treat left double-click as ENTER
  1723.       if editcell(b, hWnd)
  1724.          if b:getColumn(b:colPos):heading $ upper(indexkey(0))
  1725.             b:refreshAll()
  1726.             lKeypressed := .f.
  1727.             lWait := .t.
  1728.          else
  1729.             b:refreshCurrent()
  1730.             do while ! b:stabilize()
  1731.             enddo
  1732.          endif
  1733.       else
  1734.          b:refreshCurrent()
  1735.          do while ! b:stabilize()
  1736.          enddo
  1737.       endif
  1738.  
  1739.    case nEvent == EVENT_LCLICK
  1740.       //───── determine number of visible columns (with separators)
  1741.       nColumn := b:leftVisible - 1
  1742.       nWidth := 0
  1743.       do while ++nColumn <= b:rightVisible
  1744.          nWidth += b:colWidth(nColumn) + 1
  1745.       enddo
  1746.       //───── since the TBrowse is always centered, find the left padding
  1747.       nWidth := int((b:nRight - b:nLeft + 1 - nWidth) / 2)
  1748.  
  1749.       //───── now locate column in which mouse cursor sits
  1750.       nColumn := b:leftVisible - 1
  1751.       do while ++nColumn <= b:colCount .and. ;
  1752.                (nWidth += b:colWidth(nColumn) + 1) < MouseCol()
  1753.       enddo
  1754.       b:refreshCurrent()  // get rid of old highlight on previous row
  1755.       b:colPos := nColumn
  1756.  
  1757.       //───── the next line is purely temporary and will have to be revamped
  1758.       //───── because it makes the somewhat dangerous assumption that there
  1759.       //───── will always be a total of two lines for the column headings and
  1760.       //───── heading separator
  1761.       b:rowPos := MouseRow() - if(! empty(b:headSep), 1, 0)
  1762.       do while ! b:stabilize()
  1763.       enddo
  1764.       UpdateScrollbar(hWnd, b, @nVPos, @nHPos)
  1765.  
  1766.    case nEvent == EVENT_HSCROLL
  1767.       nScrollCmd = _lastwParam()      // from Windows
  1768.       do case
  1769.       case nScrollCmd == SB_LEFT
  1770.          x := 1
  1771.       case nScrollCmd == SB_RIGHT
  1772.          x := b:colCount
  1773.       case nScrollCmd == SB_LINELEFT
  1774.          x := max(b:colPos - 1, 1)
  1775.       case nScrollCmd == SB_LINERIGHT
  1776.          x := min(b:colPos + 1, b:colCount)
  1777.       case nScrollCmd == SB_PAGELEFT .and. b:leftVisible > 1
  1778.          b:panLeft()
  1779.          do while ! b:stabilize()
  1780.          enddo
  1781.          x := b:colPos
  1782.       case nScrollCmd == SB_PAGERIGHT .and. b:rightVisible < b:colCount
  1783.          b:panRight()
  1784.          do while ! b:stabilize()
  1785.          enddo
  1786.          x := b:colPos
  1787.       case nScrollCmd == SB_THUMBPOSITION .or. nScrollCmd == SB_THUMBTRACK
  1788.          // ignore
  1789.          x := _lastlolParam()     // from Windows
  1790.       case nScrollCmd == SB_ENDSCROLL
  1791.          x := NIL
  1792.       endcase
  1793.       if x <> NIL .and. x <> nHPos
  1794.          nHPos := x
  1795.          //───── if the target column position is already on screen,
  1796.          //───── there is no need to refresh the entire screen
  1797.          if x >= b:leftVisible .and. x <= b:rightVisible
  1798.             b:refreshCurrent()
  1799.          else
  1800.             b:refreshAll()
  1801.          endif
  1802.          b:colPos := x
  1803.          SetScrollPos(hWnd, SB_HORZ, nHPos, .t.)
  1804.          do while ! b:stabilize()
  1805.          enddo
  1806.       endif
  1807.  
  1808.    case nEvent == EVENT_VSCROLL
  1809.       nScrollCmd = _lastwParam()
  1810.       do case
  1811.       case nScrollCmd == SB_TOP
  1812.          x := 0
  1813.       case nScrollCmd == SB_BOTTOM
  1814.          x := 100
  1815.       case nScrollCmd == SB_LINEDOWN
  1816.          x := min(nVPos + 1, 100)
  1817.       case nScrollCmd == SB_PAGEDOWN
  1818.          x := min(nVPos + 10, 100)
  1819.       case nScrollCmd == SB_LINEUP
  1820.          x := max(nVPos - 1, 0)
  1821.       case nScrollCmd == SB_PAGEUP
  1822.          x := max(nVPos - 10, 0)
  1823.       case nScrollCmd == SB_THUMBPOSITION .or. nScrollCmd == SB_THUMBTRACK
  1824.          x := _lastlolParam()     // from Windows
  1825.       case nScrollCmd == SB_ENDSCROLL
  1826.          x := nVPos
  1827.       endcase
  1828.       nVPos := x
  1829.  
  1830.       //───── this IF test speeds up the "thumb" movement
  1831.       if nScrollCmd <> SB_THUMBTRACK
  1832.          SetScrollPos(hWnd, SB_VERT, x, .t.)
  1833.  
  1834.          //───── update record pointer accordingly (if necessary)
  1835.          //───── note the use of Ntxrec() if there is an active index
  1836.          if indexord() == 0 .or. empty(indexkey(0))
  1837.             nOldrec := recno()
  1838.          else
  1839.             nOldrec := ntxpos(indexord(), recno())
  1840.          endif
  1841.          nNewrec := int(x * lastrec() / 100)
  1842.          if nOldrec <> nNewrec
  1843.             nSkipcnt := nNewrec - nOldrec
  1844.             if nSkipcnt > 0                 // moving downward
  1845.                //───── see if movement can be made without updating the screen
  1846.                if nSkipcnt < b:rowCount - b:rowPos + 1
  1847.                   for x := 1 to nSkipcnt
  1848.                      b:down()
  1849.                   next
  1850.                else
  1851.                   if indexord() == 0 .or. empty(indexkey(0))
  1852.                      dbgoto(nNewrec)
  1853.                   else
  1854.                      dbgoto(ntxrec(indexord(), nNewrec))
  1855.                   endif
  1856.                   b:refreshAll()
  1857.                endif
  1858.             else                              // moving upward
  1859.                //───── see if movement can be made without updating the screen
  1860.                if nSkipcnt < b:rowPos + 1
  1861.                   for x := -1 to nSkipcnt step -1
  1862.                      b:up()
  1863.                   next
  1864.                else
  1865.                   if indexord() == 0 .or. empty(indexkey(0))
  1866.                      dbgoto(nNewrec)
  1867.                   else
  1868.                      dbgoto(ntxrec(indexord(), nNewrec))
  1869.                   endif
  1870.                   b:refreshAll()
  1871.                endif
  1872.             endif
  1873.             do while ! b:stabilize()
  1874.             enddo
  1875.         endif
  1876.       endif
  1877. endcase
  1878. select (nOldArea)
  1879. SelectWindow(hOldWnd)
  1880. return nil
  1881.  
  1882.  
  1883. /*
  1884.    Function: ShowMemo()
  1885. */
  1886. static function showmemo(b)
  1887. MessageBox( , "Showing Memo", ;
  1888.               b:cargo[B_FIELDNAMES][b:colPos], MB_ICONASTERISK + MB_OK)
  1889. return nil
  1890.  
  1891.  
  1892. /*
  1893.    Function: PickField()
  1894. */
  1895. static function pickfield(b)
  1896. local ret_val
  1897. static aDlg
  1898. if aDlg == NIL
  1899.    aDlg := CreateDialog("Available Fields",                ;
  1900.                        WS_CAPTION + WS_SYSMENU + WS_GROUP + WS_TABSTOP    ;
  1901.                        + WS_THICKFRAME + WS_VISIBLE + WS_POPUP,        ;
  1902.                        100, 30, 100, 100)
  1903.    aDlg := AppendDialog(aDlg, "listbox", DLG_LISTBOX,            ;
  1904.                        LBS_STANDARD + WS_CHILD + WS_VISIBLE + WS_TABSTOP, ;
  1905.                        10, 10, 80, 60,                    ;
  1906.                        b:cargo[B_FIELDNAMES])
  1907.    aDlg := AppendDialog(aDlg, "ok", DLG_BUTTON,                ;
  1908.                        BS_DEFPUSHBUTTON + WS_TABSTOP + WS_CHILD + WS_VISIBLE,;
  1909.                        10, 75, 35, 15,                    ;
  1910.                        "&Ok")
  1911.    aDlg := AppendDialog(aDlg, "cancel", DLG_BUTTON,            ;
  1912.                        BS_PUSHBUTTON + WS_TABSTOP + WS_CHILD + WS_VISIBLE, ;
  1913.                        55, 75, 35, 15,                    ;
  1914.                        "&Cancel")
  1915. endif
  1916. if ModalDialog(aDlg, _GetInstance(), SelectWindow()) <> 0 .and. ;
  1917.                ! GetDialogResult(aDlg, "cancel")
  1918.    ret_val := GetDialogResult(aDlg, "listbox")
  1919. endif
  1920. return ret_val
  1921.  
  1922.  
  1923. /*
  1924.    Function: UpdateScrollBar()
  1925. */
  1926. static function UpdateScrollbar(hWnd, b, nVPos, nHPos)
  1927. local ele
  1928. local nNewpos
  1929.  
  1930. //───── determine relative position
  1931. if indexord() == 0 .or. empty(indexkey(0))
  1932.    ele := recno()
  1933. else
  1934.    ele := ntxpos(indexord(), recno())
  1935. endif
  1936.  
  1937. //───── determine if vertical scrollbar indicator has changed
  1938. nNewpos := (ele / lastrec() * 100)
  1939. if nVPos <> nNewpos
  1940.    nVPos := nNewpos
  1941.    SetScrollPos(hWnd, SB_VERT, nVPos, .t.)
  1942. endif
  1943.  
  1944. //───── determine if horizontal scrollbar indicator has changed
  1945. if nHPos <> b:colPos
  1946.    nHPos := b:colPos
  1947.    SetScrollPos(hWnd, SB_HORZ, nHPos, .t.)
  1948. endif
  1949. return nil
  1950.  
  1951.  
  1952.  
  1953. /*
  1954.    Function: EditCell()
  1955. */
  1956. static function editcell(b, hWnd)
  1957. local c := b:getColumn(b:colPos)
  1958. local oldval := eval(c:block)
  1959. if rlock()
  1960.    ShowCaret(hWnd)
  1961.    // this is modal because you're changing a record, which should (in general)
  1962.    // be locked -- so you should not spend too long over it!
  1963.    // however, it could be modeless with a time-out just by using code like
  1964.    // that in ValidTest(), and DoTimer()
  1965.    readmodal( { getnew(Row(), Col(), c:block, ;
  1966.                 c:heading, '@K', b:colorSpec) } )
  1967.    dbcommit()
  1968.    dbunlock()
  1969.    HideCaret(hWnd)
  1970. endif
  1971. return ( eval(c:block) <> oldval )
  1972.  
  1973.  
  1974. /*
  1975.    Function: WinNew()
  1976. */
  1977. static function WinNew(cTitle, nX, nY, nWidth, nHeight, nStyle)
  1978. local hInst := _GetInstance()
  1979. local nCmdShow := _GetnCmdShow()
  1980. local hWin
  1981. if nStyle == NIL
  1982.    nStyle := WS_OVERLAPPEDWINDOW
  1983. endif
  1984. hWin := CreateWindow(APP_NAME,           ;       // window class
  1985.                     cTitle,              ;       // caption for title bar
  1986.                     nStyle,              ;       // window style
  1987.                     nX,                  ;       // x co-ordinate
  1988.                     nY,                  ;       // y co-ordinate
  1989.                     nWidth,              ;       // width
  1990.                     nHeight,             ;       // height
  1991.                     hFrameWnd,           ;       // hWnd of parent
  1992.                     0,                   ;       // hMenu of menu (none yet)
  1993.                     hInst)                       // our own app instance
  1994. if hWin == 0
  1995.    // probably out of resources
  1996.    MessageBox( , "Can't create window", "Error", MB_ICONEXCLAMATION + MB_OK)
  1997.    return nil
  1998. endif
  1999. HideCaret(hWin)
  2000. // make sure it's displayed ...
  2001. ShowWindow(hWin, nCmdShow)
  2002. // ... and up to date
  2003. UpdateWindow(hWin)
  2004. return hWin
  2005.  
  2006.  
  2007. /*
  2008.    Function: ResetMainEvent()
  2009.    Purpose:  Reset event handler for main window (i.e., delete the
  2010.              primary event handler, which had been changed in DoOpen())
  2011. */
  2012. static function ResetMainEvent
  2013. local hMenu
  2014. DelHandler(nMainEvId)
  2015. nMainEvId := AddHandler(hWnd, {|nEvent| MainEvent(nEvent)})
  2016. //───── disable the "Clear" and "Cut" menu items
  2017. hMenu := GetMenu(hFrameWnd)       // retrieve reference to main menu
  2018. EnableMenuItem(hMenu, "clear", MF_GRAYED)
  2019. EnableMenuItem(hMenu, "cut", MF_GRAYED)
  2020. //───── force main window to be redrawn immediately
  2021. InvalidateRect(hWnd)
  2022. return nil
  2023.  
  2024.  
  2025. /*
  2026.    Function: ValidTest()
  2027. */
  2028. static function ValidTest
  2029. local cFruit := space(10)
  2030. local hWnd := WinNew("Sample Listbox Validation", 0, 0, 300, 100)
  2031. local getlist := {}
  2032. local nHand
  2033. ShowCaret(hWnd)
  2034. @ 2,5 say "Type in a fruit" color 'n/w' ;
  2035.       get cFruit color '+w/b,+w/b' valid FruitLook()
  2036. nHand := AddHandler(hWnd, {|nEvent| ValidEvent(GetList, nEvent, hWnd, nHand, cFruit)})
  2037. return nil
  2038.  
  2039.  
  2040. /*
  2041.    Procedure: ValidEvent()
  2042. */
  2043. static procedure ValidEvent(GetList, nEvent, hWnd, nHand, cFruit)
  2044. local    hOldWnd
  2045. local    lDone := (GetList[1] == nil)    // only do the read until it finishes
  2046. if !lDone
  2047.     if nEvent == EVENT_REDRAW
  2048.         hOldWnd = SelectWindow(hWnd)
  2049.         @ 2,5 say "Type in a fruit" color 'n/w'
  2050.         SelectWindow(hOldWnd)
  2051.     endif
  2052.     if ReadModeless(GetList, nEvent) == NIL
  2053.         // not yet done
  2054.         return                // wait for next event
  2055.     endif
  2056. endif
  2057. // getting here means the read has completed (or been abandoned)
  2058.  
  2059. if nEvent == EVENT_DESTROY
  2060.     // abandoned
  2061.     return
  2062. endif
  2063. if !lDone
  2064.     // get here exactly once
  2065.     // (immediately after ReadModeless() returns non-NIL)
  2066.     GetList[1] := nil        // cancel the GET
  2067.     HideCaret(hWnd)
  2068.     InvalidateRect(hWnd)        // trigger a re-draw (below)
  2069. endif
  2070.  
  2071. do case
  2072. case nEvent == EVENT_REDRAW
  2073.     hOldWnd = SelectWindow(hWnd)
  2074.     @ 2,5 say "Fruit selected: " + cFruit color '+r/w'
  2075.     SelectWindow(hOldWnd)
  2076. endcase
  2077. return
  2078.  
  2079.  
  2080. /*
  2081.    Function: FruitLook()
  2082. */
  2083. static function FruitLook
  2084. static aChoices := {"Apple", "Banana", "Coconut", "Grape", "Grapefuit", ;
  2085.             "Lemon", "Lime", "Orange", "Papaya", "Pineapple",   ;
  2086.             "Raisin", "Raspberry", "Strawberry" }
  2087. local g := getactive()
  2088. local v := upper( g:varGet() )
  2089. static aDlg
  2090. if ascan(aChoices, { | f | upper(f) = upper(v) } ) == 0
  2091.    if aDlg == NIL
  2092.       aDlg := CreateDialog("Fruit List",                  ;
  2093.                           WS_CAPTION + WS_SYSMENU + WS_GROUP + WS_TABSTOP ;
  2094.                           + WS_THICKFRAME + WS_VISIBLE + WS_POPUP,      ;
  2095.                           100, 30, 100, 100)
  2096.       aDlg := AppendDialog(aDlg, "listbox", DLG_LISTBOX,          ;
  2097.                           LBS_STANDARD + WS_TABSTOP + WS_CHILD + WS_VISIBLE, ;
  2098.                           10, 10, 80, 60,                  ;
  2099.                           aChoices)
  2100.       aDlg := AppendDialog(aDlg, "ok", DLG_BUTTON,              ;
  2101.                           BS_DEFPUSHBUTTON + WS_TABSTOP + WS_CHILD + WS_VISIBLE,;
  2102.                           10, 75, 35, 15,                  ;
  2103.                           "&Ok")
  2104.       aDlg := AppendDialog(aDlg, "cancel", DLG_BUTTON,              ;
  2105.                           BS_PUSHBUTTON + WS_TABSTOP + WS_CHILD + WS_VISIBLE, ;
  2106.                           55, 75, 35, 15,                  ;
  2107.                           "&Cancel")
  2108.    endif
  2109.    if ModalDialog(aDlg) <> 0 .and. ! GetDialogResult(aDlg, "cancel")
  2110.       g:varPut( padr(GetDialogResult(aDlg, "listbox"), len(g:buffer)) )
  2111.    endif
  2112. endif
  2113. return .t.
  2114.  
  2115.  
  2116. /*
  2117.    Function: ToggleItem()
  2118.    Purpose:  Demonstrate how to check and uncheck any menu item
  2119. */
  2120. static function ToggleItem(cItem)
  2121. local hMenu := GetMenu(hFrameWnd)       // retrieve reference to main menu
  2122. local nCheck := CheckMenuItem(hMenu, cItem)
  2123. CheckMenuItem(hMenu, cItem, if(nCheck == MF_CHECKED, MF_UNCHECKED, MF_CHECKED))
  2124. return nil
  2125.  
  2126. //───── end of file DEMO.PRG
  2127.