home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / PMNEWUP.ZIP / PMNEWUP.CBL < prev    next >
Text File  |  1990-01-16  |  49KB  |  1,136 lines
  1.       $set ans85 mf noosvs defaultbyte"00" callfh"extfh"
  2.       *--------------------------------------------------------------*
  3.       * PMNEWUP.CBL.
  4.       *
  5.       * Copyright 1989, Micro Focus Ltd.
  6.       * Author B J Edwards
  7.       *--------------------------------------------------------------*
  8.  
  9.        environment division.
  10.        special-names.
  11.             call-convention 3 is OS2API.
  12.  
  13.       *---------------------------------------------------------------*
  14.        input-output section.
  15.        file-control.
  16.            select PmFile assign "pmfile.ism"
  17.            organization is indexed
  18.            file status is file-status
  19.            record key is file-record-key
  20.            access is dynamic.
  21.  
  22.       ******************* DATA DIVISION *******************************
  23.        data division.
  24.  
  25.       *---------------------------------------------------------------*
  26.        file section.
  27.        fd  PmFile.
  28.        01  PmFileRecord.
  29.             03 file-record-key     pic x(5).
  30.             03 file-numeric-value  pic 9(4).
  31.             03 file-another-1      pic x(20).
  32.             03 file-another-2      pic x(20).
  33.  
  34.         working-storage section.
  35.  
  36.         copy "fcf.78".
  37.         copy "en.78".
  38.         copy "em.78".
  39.         copy "es.78".
  40.         copy "cs.78".
  41.         copy "wc.78".
  42.         copy "mb.78".
  43.         copy "wm.78".
  44.         copy "ws.78".
  45.         copy "vk.78".
  46.         copy "qw.78".
  47.         copy "swp.78".
  48.         copy "fid.78".
  49.         copy "mbid.78".
  50.         copy "hwnd.78".
  51.         copy "sptr.78".
  52.         copy "cursor.78".
  53.  
  54.       ****************************************************************
  55.         copy "pmnewup.cpy".
  56.       ****************************************************************
  57.         78  object-id-1         value 999.
  58.         78  object-id-2         value 998.
  59.         78  object-id-3         value 997.
  60.         78  object-id-4         value 996.
  61.  
  62.         77  MY-MB               pic 9(4) comp-5.
  63.         77  object-flag         pic 99 comp-5 value 0.
  64.         77  msg-box-answer      pic 9(4) comp-5.
  65.  
  66.         01  file-status         pic xx.
  67.  
  68.         01  entry-field-contents.
  69.  
  70.           78 field-1-start value NEXT.
  71.             03 entry-field-1         pic x(5).
  72.           78 size-of-field-1 value NEXT - field-1-start.
  73.  
  74.             03 filler                pic x value x"00".
  75.  
  76.           78 field-2-start value NEXT.
  77.             03 entry-field-2         pic 9(4).
  78.           78 size-of-field-2 value NEXT - field-2-start.
  79.             03 entry-field-2-x redefines entry-field-2 pic x(4).
  80.  
  81.             03 filler                pic x value x"00".
  82.  
  83.           78 field-3-start value NEXT.
  84.             03 entry-field-3         pic x(20).
  85.           78 size-of-field-3 value NEXT - field-3-start.
  86.  
  87.             03 filler                pic x value x"00".
  88.  
  89.           78 field-4-start value NEXT.
  90.             03 entry-field-4         pic x(20).
  91.           78 size-of-field-4 value NEXT - field-4-start.
  92.             03 filler                pic x value x"00".
  93.  
  94.         78 valid-new-msg         value "Record written..........".
  95.         78 valid-load-msg        value "Record read.............".
  96.         78 valid-delete-msg      value "Record deleted..........".
  97.         78 valid-overwrite-msg   value "Record rewritten........".
  98.         78 not-deleted-msg       value "Record not deleted......".
  99.  
  100.         78 invalid-new-msg       value "ERROR: Record exists..........".
  101.         78 invalid-load-msg      value "ERROR: Record not found.......".
  102.         78 invalid-delete-msg    value "ERROR: Record not present.....".
  103.         78 invalid-overwrite-msg value "ERROR: Record not present.....".
  104.         78 invalid-key-msg       value "ERROR: Record key empty.......".
  105.  
  106.         78 delete-msg-confirm    value "Delete. Are you sure?".
  107.  
  108.         01 No-help-yet-message.
  109.            03   pic x(42)
  110.               value "This program is written using Micro Focus ".
  111.            03   pic x(40)
  112.               value "COBOL/2. The source for this program is ".
  113.            03   pic x(42)
  114.               value "available in the program PMNEWUP.CBL. The ".
  115.            03   pic x(40)
  116.               value "program was written by B J Edwards.".
  117.            03   pic x     value x"00".
  118.  
  119.         01  end-message.
  120.            03   pic x(40) value "Do you really want to end?".
  121.            03   pic x     value x"00".
  122.  
  123.         78 no-numerics-msg       value "Numeric Characters not allowed".
  124.         78 numerics-only-msg     value "Numeric Characters only".
  125.  
  126.         01  work-data.
  127.             03 hab                 pic 9(9) comp-5.
  128.             03 hmq                 pic 9(9) comp-5.
  129.             03 hwndClient          pic 9(9) comp-5.
  130.             03 hwndFrame           pic 9(9) comp-5.
  131.             03 hwndParent          pic 9(9) comp-5.
  132.             03 hwndMenu            pic 9(9) comp-5.
  133.             03 hwndEntryField      pic xxxx comp-5.
  134.             03 hwndEntryField-1    pic xxxx comp-5.
  135.             03 hwndEntryField-2    pic xxxx comp-5.
  136.             03 hwndEntryField-3    pic xxxx comp-5.
  137.             03 hwndEntryField-4    pic xxxx comp-5.
  138.             03 nullText            pic x  value x"00".
  139.             03 ClientWndProc       procedure-pointer.
  140.             03 temp-long           pic 9(9) comp-5.
  141.             03 EntryFieldWinProc  redefines temp-long procedure-pointer.
  142.             03 DefEntryFieldWinProc
  143.                          REDEFINES temp-long procedure-pointer.
  144.             03 qmsg.
  145.                05  qmsghwnd        pic 9(9) comp-5.
  146.                05  qmsgmsg         pic 9(4) comp-5.
  147.                05  qmsgmp1         pic 9(9) comp-5.
  148.                05  qmsgmp2         pic 9(9) comp-5.
  149.                05  qmsgtime        pic 9(9) comp-5.
  150.                05  qmsgptl.
  151.                    07  qmsgptlx    pic 9(9) comp-5.
  152.                    07  qmsgptly    pic 9(9) comp-5.
  153.             03 loop-flag           pic x value 'C'.
  154.                88  loop-end            value 'E'.
  155.             03 bool                pic 9(4) comp-5.
  156.                88  boolTRUE            value 1.
  157.                88  boolFALSE           value 0.
  158.  
  159.             03  flFrameFlags        pic 9(9) comp-5.
  160.             03  winStyle            pic 9(9) comp-5.
  161.             03  szClientClass       pic x(10) value 'FileUpdate'.
  162.             03  filler              pic x    value x"00".
  163.             03  sFlag               pic 9(4)  comp-5.
  164.             03  temp-num1           pic 9(4)  comp-5.
  165.             03  temp-num2           pic 9(4)  comp-5.
  166.           78  screen-message-start value NEXT.
  167.             03  screen-message       pic x(32).
  168.           78  size-of-message-line value NEXT - screen-message-start.
  169.  
  170.        01  workarea.
  171.             03  temp-word       pic xx   comp-5.
  172.             03  REDEFINES temp-word.
  173.                 05 temp-ls      pic x   comp-5.
  174.                 05 temp-ms      pic x   comp-5.
  175.  
  176.        01  field-coords.
  177.            03  x           pic s9(4) comp-5.
  178.            03  y           pic s9(4) comp-5.
  179.  
  180.        01  short-vars.
  181.            03  cxChar      pic s9(4) comp-5.
  182.            03  cxCaps      pic s9(4) comp-5.
  183.            03  cyChar      pic s9(4) comp-5.
  184.            03  cyDesc      pic s9(4) comp-5.
  185.            03  cxClient    pic s9(4) comp-5.
  186.            03  cyClient    pic s9(4) comp-5.
  187.  
  188.        01  mp3                 pic xxxx comp-5.
  189.        01  redefines mp3.
  190.            03  mp3w1           pic xx   comp-5.
  191.            03  mp3w2           pic xx   comp-5.
  192.  
  193.        01  hdr1-line.
  194.          78 hdr1-line-start value NEXT.
  195.            03                     pic x(65) value
  196.                        "Simple Presentation Manager, COBOL Indexed File,
  197.       -                " update program".
  198.          78 size-of-hdr1-line value NEXT - hdr1-line-start.
  199.            03                     pic x value x"00".
  200.  
  201.        01 Character-bits.
  202.             03  ACTUAL-KC-INVALIDCHAR    pic 9.
  203.             03  ACTUAL-KC-TOGGLE         pic 9.
  204.             03  ACTUAL-KC-INVALIDCOMP    pic 9.
  205.             03  ACTUAL-KC-COMPOSITE      pic 9.
  206.             03  ACTUAL-KC-DEADKEY        pic 9.
  207.             03  ACTUAL-KC-LONEKEY        pic 9.
  208.             03  ACTUAL-KC-PREVDOWN       pic 9.
  209.             03  ACTUAL-KC-KEYUP          pic 9.
  210.             03  ACTUAL-KC-ALT            pic 9.
  211.             03  ACTUAL-KC-CTRL           pic 9.
  212.             03  ACTUAL-KC-SHIFT          pic 9.
  213.             03  ACTUAL-KC-SCANCODE       pic 9.
  214.             03  ACTUAL-KC-VIRTUALKEY     pic 9.
  215.             03  ACTUAL-KC-CHAR           pic 9.
  216.  
  217.  
  218.       *---------------------------------------------------------*
  219.         local-storage section.
  220.  
  221.         01  hps                 pic x(4) comp-5.
  222.  
  223.         01  swp.
  224.             03                  PIC 9(4) COMP-5.
  225.             03 win-size.
  226.                05  sxLeft          pic x(2) comp-5.
  227.                05  syBottom        pic x(2) comp-5.
  228.                05  sxRight         pic x(2) comp-5.
  229.                05  syTop           pic x(2) comp-5.
  230.             03                     PIC 9(9) COMP-5.
  231.             03                     PIC 9(9) COMP-5.
  232.  
  233.         01 ptl.
  234.             03  x       pic s9(9) comp-5.
  235.             03  y       pic s9(9) comp-5.
  236.  
  237.             copy "RECTL.CPY".
  238.  
  239.         01  mresult             pic x(4) comp-5.
  240.  
  241.       *---------------------------------------------------------*
  242.        linkage section.
  243.        01  hwnd                pic xxxx comp-5.
  244.        01  msg                 pic xx   comp-5.
  245.  
  246.        01  mp1                 pic xxxx comp-5.
  247.        01  redefines mp1.
  248.            03  mp1w1           pic xx   comp-5.
  249.            03  mp1w2           pic xx   comp-5.
  250.        01  redefines mp1.
  251.            03 fs               pic 9(4)  comp-5.
  252.            03 cRepeat          pic 99   comp-5.
  253.            03 scancode         pic 99   comp-5.
  254.            03 scancode-x   redefines scancode pic x.
  255.  
  256.        01  mp2                 pic xxxx comp-5.
  257.        01  redefines mp2.
  258.            03  mp2w1           pic xx   comp-5.
  259.            03  mp2w2           pic xx   comp-5.
  260.        01  redefines mp2.
  261.            03 chr              pic 9(4)  comp-5.
  262.            03 chr-x        redefines chr
  263.                                pic xx.
  264.            03 vKey             pic 9(4)  comp-5.
  265.  
  266.       *---------------------------------------------------------*
  267.         procedure division OS2API.
  268.         main section.
  269.            perform start-up
  270.            perform register-classes
  271.            if boolTRUE
  272.                perform open-file
  273.                perform create-client-window
  274.                perform set-data-entry-first-field
  275.                if hwndFrame not = 0
  276.                     perform message-loop until loop-end
  277.                end-if
  278.                close PmFile
  279.            end-if
  280.            perform shut-down
  281.            stop run.
  282.  
  283.       *---------------------------------------------------------*
  284.        start-up section.
  285.            perform set-procedure-entry-point
  286.            call OS2API 'WinInitialize'
  287.                        using   by value 0 size 2
  288.                        returning hab
  289.  
  290.            call OS2API 'WinCreateMsgQueue'
  291.                        using by value hab
  292.                              by value 0 size 2
  293.                        returning hmq.
  294.  
  295.       *---------------------------------------------------------*
  296.        set-procedure-entry-point section.
  297.            set ClientWndProc to ENTRY 'ClientWndProc'.
  298.  
  299.       *---------------------------------------------------------*
  300.        register-classes section.
  301.            call OS2API 'WinRegisterClass'
  302.                        using by value     hab
  303.                              by reference szClientClass
  304.                              by value     ClientWndProc
  305.                              by value     CS-SIZEREDRAW size 4
  306.                              by value     0        size 2
  307.                        returning bool.
  308.  
  309.       *---------------------------------------------------------*
  310.        message-loop section.
  311.            call OS2API 'WinGetMsg'
  312.                          using   by value hab
  313.                                  by reference qmsg
  314.                                  by value 0            size 4
  315.                                  by value 0            size 2
  316.                                  by value 0            size 2
  317.                          returning bool
  318.  
  319.            if boolFALSE
  320.                 add MB-YESNOCANCEL MB-ICONQUESTION giving MY-MB
  321.                 call OS2API 'WinMessageBox'
  322.                       using by value HWND-DESKTOP size 4
  323.                             by value hwndClient
  324.                             by reference end-message
  325.                             by reference szClientClass
  326.                             by value 0 size 2
  327.                             by value MY-MB
  328.                       returning msg-box-answer
  329.                 if msg-box-answer = MBID-YES
  330.                     set loop-end to true
  331.                 else
  332.                     call OS2API 'WinCancelShutdown'
  333.                          using by value hmq
  334.                                by value 0 size 2
  335.                 end-if
  336.            else
  337.                 call OS2API 'WinDispatchMsg'
  338.                          using by value hab
  339.                                by reference qmsg
  340.            end-if.
  341.       *---------------------------------------------------------*
  342.        shut-down section.
  343.            call OS2API 'WinDestroyWindow'   using by value hwndFrame
  344.            call OS2API 'WinDestroyMsgQueue' using by value hmq
  345.            call OS2API 'WinTerminate'       using by value hab.
  346.       *---------------------------------------------------------*
  347.        create-client-window section.
  348.            compute flFrameFlags = FCF-TITLEBAR   + FCF-SYSMENU
  349.                                 + FCF-SIZEBORDER + FCF-MINBUTTON
  350.                                 + FCF-MAXBUTTON  + FCF-SHELLPOSITION
  351.                                 + FCF-TASKLIST   + FCF-MENU
  352.                                 + FCF-ACCELTABLE + FCF-ICON
  353.  
  354.            call OS2API 'WinCreateStdWindow'
  355.                             using by value     HWND-DESKTOP size 4
  356.                                   by value     WS-VISIBLE size 4
  357.                                   by reference flFrameFlags
  358.                                   by reference szClientClass
  359.                                   by reference nulltext
  360.                                   by value     0        size 4
  361.                                   by value     0        size 2
  362.                                   by value     ID-RESOURCE  size 2
  363.                                   by reference hwndClient
  364.                             returning hwndFrame
  365.  
  366.            call OS2API 'WinQueryWindowPos'
  367.                           using   by value hwndFrame
  368.                                   by reference swp
  369.                           returning bool
  370.  
  371.            call OS2API 'WinSetWindowPos'
  372.                                 using by value hwndFrame
  373.                                       by value HWND-TOP size 4
  374.                                       by value 0        size 2
  375.                                       by value 0        size 2
  376.                                       by value 0        size 2
  377.                                       by value 0        size 2
  378.                                       by value SWP-ACTIVATE size 2.
  379.  
  380.       *---------------------------------------------------------------*
  381.        set-data-entry-first-field section.
  382.            call OS2API 'WinSetFocus'
  383.                           using by value HWND-DESKTOP size 4
  384.                                 by value hwndEntryField-1.
  385.       *---------------------------------------------------------------
  386.         MyWndProc-S section.
  387.         entry 'ClientWndProc' using by value hwnd
  388.                               by value msg
  389.                               by value mp1
  390.                               by value mp2.
  391.  
  392.             move 0 to mresult
  393.             evaluate msg
  394.  
  395.                when WM-CREATE
  396.  
  397.                    perform WM-CREATE-routine
  398.  
  399.                when WM-PAINT
  400.  
  401.                    perform WM-PAINT-routine
  402.  
  403.                when WM-SIZE
  404.  
  405.                    perform WM-SIZE-routine
  406.  
  407.                when WM-CONTROL
  408.  
  409.                    perform WM-CONTROL-routine
  410.  
  411.                when WM-COMMAND
  412.  
  413.                    perform WM-COMMAND-routine
  414.  
  415.                when WM-HELP
  416.                    perform WM-HELP-routine
  417.  
  418.                when OTHER
  419.                    PERFORM Call-Default-WinProc
  420.  
  421.             end-evaluate
  422.             exit program returning mresult.
  423.  
  424.       *-----------------------------------------------------------------
  425.        WM-CREATE-routine section.
  426.            call OS2API 'WinQueryWindow'
  427.                           using by value hwnd
  428.                                 by value QW-PARENT size 2
  429.                                 by value 0 size 2
  430.                           returning hwndParent
  431.  
  432.            call OS2API 'WinWindowFromID'
  433.                           using by value hwndParent
  434.                                 by value FID-MENU size 2
  435.                           returning hwndMenu
  436.  
  437.            move low-values to entry-field-contents
  438.       *    move 0 to entry-field-2
  439.            move spaces to screen-message
  440.            move 0 to mResult.
  441.       *-----------------------------------------------------------------
  442.        WM-PAINT-routine section.
  443.            call OS2API 'WinBeginPaint'
  444.                                 using by value hwnd
  445.                                       by value 0 size 4
  446.                                       by value 0 size 4
  447.                                 returning hps
  448.  
  449.            call OS2API 'GpiErase'
  450.                                 using by value hps
  451.  
  452.            move 0   to x of ptl
  453.            compute y of ptl = cyClient - 15
  454.  
  455.            call OS2API 'GpiCharStringAt'
  456.                                 using by value hps
  457.                                       by reference ptl
  458.                                       by value size-of-hdr1-line
  459.                                       by reference hdr1-line
  460.  
  461.            compute x of ptl = cxClient / 5
  462.            compute y of ptl = cyClient / 2 + 20
  463.  
  464.            call OS2API 'GpiCharStringAt'
  465.                                 using by value hps
  466.                                       by reference ptl
  467.                                       by value 10 size 4
  468.                                       by reference "Record Key"
  469.  
  470.            compute x of ptl = (cxClient / 5) * 3
  471.            compute y of ptl = cyClient / 2 + 20
  472.  
  473.            call OS2API 'GpiCharStringAt'
  474.                                 using by value hps
  475.                                       by reference ptl
  476.                                       by value 14 size 4
  477.                                       by reference "Data Field 1"
  478.  
  479.            compute x of ptl = cxClient / 5
  480.            compute y of ptl = cyClient / 4 + 20
  481.  
  482.            call OS2API 'GpiCharStringAt'
  483.                                 using by value hps
  484.                                       by reference ptl
  485.                                       by value 14 size 4
  486.                                       by reference "Data Field 2"
  487.  
  488.            compute x of ptl = (cxClient / 5) * 3
  489.            compute y of ptl = cyClient / 4 + 20
  490.  
  491.            call OS2API 'GpiCharStringAt'
  492.                                 using by value hps
  493.                                       by reference ptl
  494.                                       by value 14 size 4
  495.                                       by reference "Data Field 3"
  496.  
  497.            move 1  to x of ptl
  498.            move 20 to y of ptl
  499.  
  500.            call OS2API 'GpiCharStringAt'
  501.                                 using by value hps
  502.                                       by reference ptl
  503.                                       by value size-of-message-line
  504.                                       by reference screen-message
  505.  
  506.            call OS2API 'WinEndPaint' using by value hps
  507.            move 0 to mResult.
  508.       *-----------------------------------------------------------------
  509.        WM-SIZE-routine section.
  510.            move mp2w1 to cxClient
  511.            move mp2w2 to cyClient
  512.            if hwndEntryField-1 not = 0
  513.                PERFORM get-screen-contents
  514.                PERFORM Destroy-Entry-Fields
  515.            end-if
  516.            PERFORM Create-Entry-Fields
  517.            move 0 to mResult.
  518.       *-----------------------------------------------------------------
  519.        WM-CONTROL-routine section.
  520.            IF  mp2 = hwndClient OR hwndFrame
  521.                PERFORM Call-Default-WinProc
  522.            ELSE
  523.                EVALUATE mp1w2
  524.                   WHEN EN-KILLFOCUS
  525.                       perform kill-focus
  526.                   WHEN EN-SETFOCUS
  527.                       set EntryFieldWinProc to ENTRY 'EWndProc'
  528.                       EVALUATE mp1w1
  529.                          WHEN object-id-1
  530.                             perform set-focus-1
  531.                          WHEN object-id-2
  532.                             perform set-focus-2
  533.                          WHEN object-id-3
  534.                             perform set-focus-3
  535.                          WHEN object-id-4
  536.                             perform set-focus-4
  537.                       END-EVALUATE
  538.                       PERFORM Call-Default-WinProc
  539.                END-EVALUATE
  540.            END-IF.
  541.       *-----------------------------------------------------------------
  542.        WM-COMMAND-routine section.
  543.            evaluate mp1w1
  544.                when IDM-READ
  545.                    perform load-record
  546.                when IDM-DELETE
  547.                    perform delete-record
  548.                when IDM-WRITE
  549.                    perform save-new-record
  550.                when IDM-REWRITE
  551.                    perform overwrite-record
  552.                when IDM-PREVIOUS
  553.                    perform read-previous
  554.                when IDM-NEXT
  555.                    perform read-next
  556.                when IDM-CLEAR
  557.                    perform clear-record
  558.                when IDM-EXIT
  559.                    call OS2API 'WinSendMsg'
  560.                       using by value hwnd
  561.                             by value WM-CLOSE size 2
  562.                             by value 0        size 4
  563.                             by value 0        size 4
  564.  
  565.            end-evaluate
  566.            move 0 to mresult.
  567.       *-----------------------------------------------------------------
  568.        WM-HELP-routine section.
  569.            add MB-OK MB-ICONEXCLAMATION giving MY-MB
  570.            call OS2API 'WinMessageBox'using
  571.                  by value HWND-DESKTOP size 4
  572.                  by value hwnd
  573.                  by reference No-help-yet-message
  574.                  by reference szClientClass
  575.                  by value 0 size 2
  576.                  by value MY-MB
  577.            move 0 to mresult.
  578.       *---------------------------------------------------------------*
  579.        Confirm-delete-routine section.
  580.            add MB-YESNO MB-ICONEXCLAMATION giving MY-MB
  581.            call OS2API 'WinMessageBox' using
  582.                  by value HWND-DESKTOP size 4
  583.                  by value hwnd
  584.                  by reference delete-msg-confirm
  585.                  by reference szClientClass
  586.                  by value 0 size 2
  587.                  by value MY-MB
  588.              returning msg-box-answer.
  589.       *---------------------------------------------------------------*
  590.        process-virtual-keys section.
  591.            evaluate vKey
  592.                when VK-TAB
  593.                   perform skip-next-field
  594.                when VK-BACKTAB
  595.                   perform skip-previous-field
  596.                when other
  597.                   PERFORM Call-Default-EntryFieldWinProc
  598.            end-evaluate.
  599.       *---------------------------------------------------------------*
  600.        skip-next-field section.
  601.            if object-flag not = 0
  602.                evaluate object-flag
  603.                    when 1
  604.                        move hwndEntryField-2 to hwndEntryField
  605.                    when 2
  606.                        move hwndEntryField-3 to hwndEntryField
  607.                    when 3
  608.                        move hwndEntryField-4 to hwndEntryField
  609.                    when 4
  610.                        move hwndEntryField-1 to hwndEntryField
  611.                end-evaluate
  612.                call OS2API 'WinSetFocus'
  613.                       using by value HWND-DESKTOP size 4
  614.                             by value hwndEntryField
  615.            end-if.
  616.       *---------------------------------------------------------------*
  617.        skip-previous-field section.
  618.            if object-flag not = 0
  619.                evaluate object-flag
  620.                    when 1
  621.                        move hwndEntryField-4 to hwndEntryField
  622.                    when 2
  623.                        move hwndEntryField-1 to hwndEntryField
  624.                    when 3
  625.                        move hwndEntryField-2 to hwndEntryField
  626.                    when 4
  627.                        move hwndEntryField-3 to hwndEntryField
  628.                end-evaluate
  629.                call OS2API 'WinSetFocus'
  630.                       using by value HWND-DESKTOP size 4
  631.                             by value hwndEntryField
  632.            end-if.
  633.       *---------------------------------------------------------------*
  634.        EntryFieldWinProc-E SECTION.
  635.        ENTRY 'EWndProc' USING BY VALUE hwnd
  636.                               BY VALUE msg
  637.                               BY VALUE mp1
  638.                               BY VALUE mp2.
  639.  
  640.            MOVE ZERO TO mresult
  641.            EVALUATE msg
  642.               WHEN WM-CHAR
  643.                  perform WM-CHAR-routine
  644.  
  645.               WHEN OTHER
  646.                  PERFORM Call-Default-EntryFieldWinProc
  647.  
  648.            END-EVALUATE
  649.            EXIT PROGRAM RETURNING mresult.
  650.  
  651.       *-----------------------------------------------------------------
  652.        WM-CHAR-routine section.
  653.            perform strip-sFlag-bits
  654.            if ACTUAL-KC-VIRTUALKEY = 1
  655.                if ACTUAL-KC-KEYUP not = 1
  656.                    perform process-virtual-keys
  657.                else
  658.                    PERFORM Call-Default-EntryFieldWinProc
  659.                end-if
  660.            else
  661.                MOVE mp1w1 TO Temp-Word
  662.                MULTIPLY 128 BY Temp-LS
  663.                IF  Temp-LS > ZERO
  664.       *----------------------------------------*
  665.       * Field  1 does not allow numerics       *
  666.       * Field  2 is numeric                    *
  667.       * Fields 3 & 4 can be any character      *
  668.       *----------------------------------------*
  669.                   EVALUATE hwnd
  670.                      WHEN hwndEntryField-1
  671.                         IF  mp2w1 > 47 AND < 58
  672.                            move no-numerics-msg to screen-message
  673.                            perform display-screen-message
  674.                            PERFORM sound-beep
  675.                         ELSE
  676.                            perform test-for-message-suppression
  677.                            PERFORM Call-Default-EntryFieldWinProc
  678.                         END-IF
  679.                      WHEN hwndEntryField-2
  680.                         IF  (mp2w1 > 47 AND < 58) OR mp2w1 < 32
  681.                            perform test-for-message-suppression
  682.                            PERFORM Call-Default-EntryFieldWinProc
  683.                         ELSE
  684.                            move numerics-only-msg to screen-message
  685.                            perform display-screen-message
  686.                            PERFORM sound-beep
  687.                         END-IF
  688.                      WHEN hwndEntryField-3
  689.                      WHEN hwndEntryField-4
  690.                         perform test-for-message-suppression
  691.                         PERFORM Call-Default-EntryFieldWinProc
  692.                      WHEN OTHER
  693.                         PERFORM Call-Default-EntryFieldWinProc
  694.                   END-EVALUATE
  695.                ELSE
  696.                   PERFORM Call-Default-EntryFieldWinProc
  697.                END-IF
  698.            END-IF.
  699.       *-----------------------------------------------------------------
  700.        get-screen-contents section.
  701.       * For reasons which escape me, it seems that the size of the
  702.       * field must be set to 1 greater than it really is. This is
  703.       * not a bug, it is described as a feature!
  704.  
  705.             call OS2API 'WinQueryWindowText'
  706.                              using by value hwndEntryField-1
  707.                                    by value 6 size 2
  708.                                    by reference entry-field-1
  709.  
  710.             call OS2API 'WinQueryWindowText'
  711.                            using by value hwndEntryField-2
  712.                                  by value 5 size 2
  713.                                  by reference entry-field-2-x
  714.  
  715.             call OS2API 'WinQueryWindowText'
  716.                            using by value hwndEntryField-3
  717.                                  by value 21 size 2
  718.                                  by reference entry-field-3
  719.  
  720.             call OS2API 'WinQueryWindowText'
  721.                            using by value hwndEntryField-4
  722.                                  by value 21 size 2
  723.                                  by reference entry-field-4.
  724.       *-----------------------------------------------------------------
  725.        Create-Entry-Fields SECTION.
  726.            compute winstyle = WS-VISIBLE + ES-LEFT +
  727.                               ES-MARGIN
  728.            compute x of field-coords = cxClient / 5
  729.            compute y of field-coords = cyClient / 2
  730.            call OS2API 'WinCreateWindow'
  731.                        using by value hwndClient
  732.                              by value WC-ENTRYFIELD size 4
  733.                              by reference entry-field-1
  734.                              by value winstyle
  735.                              by value x of field-coords
  736.                              by value y of field-coords
  737.                              by value 60            size 2
  738.                              by value 14            size 2
  739.                              by value hwndClient
  740.                              by value HWND-TOP      size 4
  741.                              by value object-id-1   size 2
  742.                              by value 0             size 4
  743.                              by value 0             size 4
  744.                        returning hwndEntryField-1
  745.  
  746.            move size-of-field-1 to mp3w1
  747.            move 0 to mp3w2
  748.            call OS2API 'WinSendMsg'
  749.                           using   by value hwndEntryField-1
  750.                                   by value EM-SETTEXTLIMIT   size 2
  751.                                   by value mp3
  752.                                   by value 0            size 4
  753.  
  754.            compute winstyle = WS-VISIBLE + ES-RIGHT +
  755.                               ES-MARGIN
  756.            compute x of field-coords = (cxClient / 5) * 3
  757.            compute y of field-coords = cyClient / 2
  758.            call OS2API 'WinCreateWindow'
  759.                        using by value hwndClient
  760.                              by value WC-ENTRYFIELD size 4
  761.                              by reference entry-field-2-x
  762.                              by value winstyle
  763.                              by value x of field-coords
  764.                              by value y of field-coords
  765.                              by value 50            size 2
  766.                              by value 14            size 2
  767.                              by value hwndClient
  768.                              by value HWND-TOP      size 4
  769.                              by value object-id-2   size 2
  770.                              by value 0             size 4
  771.                              by value 0             size 4
  772.                        returning hwndEntryField-2
  773.  
  774.            move size-of-field-2 to mp3w1
  775.            move 0 to mp3w2
  776.            call OS2API 'WinSendMsg'
  777.                           using   by value hwndEntryField-2
  778.                                   by value EM-SETTEXTLIMIT   size 2
  779.                                   by value mp3
  780.                                   by value 0        size 4
  781.  
  782.  
  783.            compute winstyle = WS-VISIBLE + ES-AUTOSCROLL +
  784.                               ES-MARGIN
  785.            compute x of field-coords = cxClient / 5
  786.            compute y of field-coords = cyClient / 4
  787.            call OS2API 'WinCreateWindow'
  788.                        using by value hwndClient
  789.                              by value WC-ENTRYFIELD size 4
  790.                              by reference entry-field-3
  791.                              by value winstyle
  792.                              by value x of field-coords
  793.                              by value y of field-coords
  794.                              by value 90            size 2
  795.                              by value 14            size 2
  796.                              by value hwndClient
  797.                              by value HWND-TOP      size 4
  798.                              by value object-id-3   size 2
  799.                              by value 0             size 4
  800.                              by value 0             size 4
  801.                        returning hwndEntryField-3
  802.  
  803.            move size-of-field-3 to mp3w1
  804.            move 0 to mp3w2
  805.            call OS2API 'WinSendMsg'
  806.                           using   by value hwndEntryField-3
  807.                                   by value EM-SETTEXTLIMIT   size 2
  808.                                   by value mp3
  809.                                   by value 0            size 4
  810.  
  811.            compute winstyle = WS-VISIBLE + ES-AUTOSCROLL +
  812.                               ES-MARGIN
  813.            compute x of field-coords = (cxClient / 5) * 3
  814.            compute y of field-coords = cyClient / 4
  815.            call OS2API 'WinCreateWindow'
  816.                        using by value hwndClient
  817.                              by value WC-ENTRYFIELD size 4
  818.                              by reference entry-field-4
  819.                              by value winstyle
  820.                              by value x of field-coords
  821.                              by value y of field-coords
  822.                              by value 90            size 2
  823.                              by value 14            size 2
  824.                              by value hwndClient
  825.                              by value HWND-TOP      size 4
  826.                              by value object-id-4   size 2
  827.                              by value 0             size 4
  828.                              by value 0             size 4
  829.                        returning hwndEntryField-4
  830.  
  831.            move size-of-field-4 to mp3w1
  832.            move 0 to mp3w2
  833.            call OS2API 'WinSendMsg'
  834.                           using   by value hwndEntryField-4
  835.                                   by value EM-SETTEXTLIMIT   size 2
  836.                                   by value mp3
  837.                                   by value 0            size 4.
  838.       *-----------------------------------------------------------------
  839.        Destroy-Entry-Fields section.
  840.           call OS2API 'WinDestroyWindow'
  841.                          using by value hwndEntryField-1
  842.           call OS2API 'WinDestroyWindow'
  843.                          using by value hwndEntryField-2
  844.           call OS2API 'WinDestroyWindow'
  845.                          using by value hwndEntryField-3
  846.           call OS2API 'WinDestroyWindow'
  847.                          using by value hwndEntryField-4.
  848.       *-----------------------------------------------------------------
  849.        Call-Default-EntryFieldWinProc SECTION.
  850.             CALL OS2API DefEntryFieldWinProc
  851.                         using by value hwnd
  852.                               by value msg
  853.                               by value mp1
  854.                               by value mp2
  855.                         returning mresult.
  856.  
  857.       *-----------------------------------------------------------------
  858.        Call-Default-WinProc SECTION.
  859.             CALL OS2API 'WinDefWindowProc'
  860.                         using by value hwnd
  861.                               by value msg
  862.                               by value mp1
  863.                               by value mp2
  864.                         returning mresult.
  865.       *-----------------------------------------------------------------
  866.        test-for-message-suppression section.
  867.            if screen-message not = spaces
  868.                move spaces to screen-message
  869.                perform display-screen-message
  870.            end-if.
  871.       *-----------------------------------------------------------------
  872.        sound-beep SECTION.
  873.            CALL OS2API 'DOSBEEP'
  874.                         USING BY VALUE 512 SIZE 2
  875.                                  VALUE 50  SIZE 2.
  876.       *-----------------------------------------------------------------
  877.        open-file section.
  878.            open i-o PmFile
  879.       *-----------------------------------------------------------*
  880.       * Create Header and Trailer records, if they are not already
  881.       * present. These make read next and read previous simpler to
  882.       * implement. Particularily for wrapping round the begining and
  883.       * the end of the file.
  884.       *-----------------------------------------------------------*
  885.            move low-values to file-record-key
  886.            read PmFile
  887.                invalid key
  888.                    move 0 to file-numeric-value
  889.                    move all "*" to file-another-1
  890.                    move all "*" to file-another-2
  891.                    write PmFileRecord
  892.            end-read
  893.            move high-values to file-record-key
  894.            read PmFile
  895.                invalid key
  896.                    move 0 to file-numeric-value
  897.                    move all "*" to file-another-1
  898.                    move all "*" to file-another-2
  899.                    write PmFileRecord
  900.            end-read.
  901.       *-----------------------------------------------------------------
  902.        delete-record section.
  903.            perform get-screen-contents
  904.            move entry-field-1 to file-record-key
  905.            if file-record-key = spaces or low-values
  906.                move invalid-key-msg to screen-message
  907.                perform display-screen-message
  908.            else
  909.                perform confirm-delete-routine
  910.                if msg-box-answer = MBID-YES
  911.                    delete PmFile
  912.                        invalid key
  913.                            move invalid-delete-msg to screen-message
  914.                        not invalid key
  915.                            move valid-delete-msg to screen-message
  916.                            move low-values to entry-field-contents
  917.       *                    move 0 to entry-field-2
  918.                            perform refresh-windows
  919.                    end-delete
  920.                else
  921.                    move not-deleted-msg to screen-message
  922.                end-if
  923.                perform display-screen-message
  924.            end-if.
  925.       *-----------------------------------------------------------------
  926.        read-next section.
  927.            perform get-screen-contents
  928.            initialize PmFileRecord
  929.            move entry-field-1 to file-record-key.
  930.            read PmFile
  931.            read PmFile next
  932.            if file-status not = "00" or file-record-key = high-values
  933.                move low-values to file-record-key
  934.                read PmFile
  935.                read PmFile next
  936.            end-if
  937.            perform fill-screen-from-file-record
  938.            move valid-load-msg to screen-message
  939.            perform refresh-windows
  940.            perform display-screen-message.
  941.       *-----------------------------------------------------------------
  942.        read-previous section.
  943.            perform get-screen-contents
  944.            initialize PmFileRecord
  945.            move entry-field-1 to file-record-key
  946.            read PmFile
  947.            read PmFile previous
  948.            if file-status not = "00" or file-record-key = low-values
  949.                move high-values to file-record-key
  950.                read PmFile
  951.                read PmFile previous
  952.            end-if
  953.            perform fill-screen-from-file-record
  954.            move valid-load-msg to screen-message
  955.            perform refresh-windows
  956.            perform display-screen-message.
  957.       *-----------------------------------------------------------------
  958.        clear-record section.
  959.            move low-values to entry-field-contents
  960.       *    move 0 to entry-field-2
  961.            move spaces to screen-message
  962.            perform refresh-windows
  963.            perform display-screen-message.
  964.       *-----------------------------------------------------------------
  965.        load-record section.
  966.            perform get-screen-contents
  967.            initialize PmFileRecord
  968.            move entry-field-1 to file-record-key.
  969.            if file-record-key = spaces or low-values or high-values
  970.                move invalid-key-msg to screen-message
  971.                perform display-screen-message
  972.            else
  973.                read PmFile
  974.                    invalid key
  975.                        move low-values to entry-field-contents
  976.       *                move 0 to entry-field-2
  977.                        move file-record-key to entry-field-1
  978.                        move invalid-load-msg to screen-message
  979.                    not invalid key
  980.                        perform fill-screen-from-file-record
  981.                        move valid-load-msg to screen-message
  982.                end-read
  983.                perform refresh-windows
  984.                perform display-screen-message
  985.            end-if.
  986.       *---------------------------------------------------------------*
  987.        save-new-record section.
  988.            perform get-screen-contents
  989.            perform fill-file-record-from-screen
  990.            if file-record-key = spaces or low-values or high-values
  991.                move invalid-key-msg to screen-message
  992.                perform display-screen-message
  993.            else
  994.                write PmFileRecord
  995.                    invalid key
  996.                        move invalid-new-msg to screen-message
  997.                    not invalid key
  998.                        move valid-new-msg to screen-message
  999.                end-write
  1000.                perform display-screen-message
  1001.           end-if.
  1002.       *---------------------------------------------------------------*
  1003.        overwrite-record section.
  1004.            perform get-screen-contents
  1005.            perform fill-file-record-from-screen.
  1006.            if file-record-key = spaces or low-values or high-values
  1007.                move invalid-key-msg to screen-message
  1008.                perform display-screen-message
  1009.            else
  1010.                rewrite PmFileRecord
  1011.                    invalid key
  1012.                        move invalid-overwrite-msg to screen-message
  1013.                    not invalid key
  1014.                        move valid-overwrite-msg to screen-message
  1015.                end-rewrite
  1016.                perform display-screen-message
  1017.            end-if.
  1018.       *---------------------------------------------------------------*
  1019.        display-screen-message section.
  1020.            if screen-message(1:5) = "ERROR"
  1021.               call OS2API 'WinReleasePS'
  1022.                       using by value hps
  1023.  
  1024.               call OS2API 'WinMessageBox'
  1025.                       using by value HWND-DESKTOP size 4
  1026.                             by value HWND-DESKTOP size 4
  1027.                             by reference screen-message
  1028.                             by reference szClientClass
  1029.                             by value 0 size 2
  1030.                             by value MB-HELP size 2
  1031.               move spaces to screen-message
  1032.            end-if
  1033.            move 1   to RECTL-xleft
  1034.            move 15  to RECTL-yBottom
  1035.            move 300 to RECTL-xRight
  1036.            move 35  to RECTL-yTop
  1037.            call OS2API 'WinInvalidateRect'
  1038.                            using by value hwndClient
  1039.                                  by reference rectl
  1040.                                  by value 0 size 2.
  1041.       *---------------------------------------------------------------*
  1042.        fill-file-record-from-screen section.
  1043.            move entry-field-1 to file-record-key
  1044.            move entry-field-2 to file-numeric-value
  1045.            move entry-field-3 to file-another-1
  1046.            move entry-field-4 to file-another-2.
  1047.       *---------------------------------------------------------------*
  1048.        fill-screen-from-file-record section.
  1049.            move file-record-key    to entry-field-1
  1050.            move file-numeric-value to entry-field-2
  1051.            move file-another-1     to entry-field-3
  1052.            move file-another-2     to entry-field-4.
  1053.       *---------------------------------------------------------------*
  1054.        refresh-windows section.
  1055.  
  1056.            call OS2API 'WinSetWindowText'
  1057.                        using by value hwndEntryField-1
  1058.                              by reference entry-field-1
  1059.  
  1060.            call OS2API 'WinSetWindowText'
  1061.                        using by value hwndEntryField-2
  1062.                              by reference entry-field-2-x
  1063.  
  1064.            call OS2API 'WinSetWindowText'
  1065.                        using by value hwndEntryField-3
  1066.                              by reference entry-field-3
  1067.  
  1068.            call OS2API 'WinSetWindowText'
  1069.                        using by value hwndEntryField-4
  1070.                              by reference entry-field-4.
  1071.       *---------------------------------------------------------------*
  1072.        strip-sFlag-bits section.
  1073.            move fs to sFlag
  1074.            divide sFlag     by 2 giving temp-num1
  1075.                               remainder ACTUAL-KC-CHAR
  1076.            divide temp-num1 by 2 giving temp-num2
  1077.                               remainder ACTUAL-KC-VIRTUALKEY
  1078.            divide temp-num2 by 2 giving temp-num1
  1079.                               remainder ACTUAL-KC-SCANCODE
  1080.            divide temp-num1 by 2 giving temp-num2
  1081.                               remainder ACTUAL-KC-SHIFT
  1082.            divide temp-num2 by 2 giving temp-num1
  1083.                               remainder ACTUAL-KC-CTRL
  1084.            divide temp-num1 by 2 giving temp-num2
  1085.                               remainder ACTUAL-KC-ALT
  1086.            divide temp-num2 by 2 giving temp-num1
  1087.                               remainder ACTUAL-KC-KEYUP
  1088.            divide temp-num1 by 2 giving temp-num2
  1089.                               remainder ACTUAL-KC-PREVDOWN
  1090.            divide temp-num2 by 2 giving temp-num1
  1091.                               remainder ACTUAL-KC-LONEKEY
  1092.            divide temp-num1 by 2 giving temp-num2
  1093.                               remainder ACTUAL-KC-DEADKEY
  1094.            divide temp-num2 by 2 giving temp-num1
  1095.                               remainder ACTUAL-KC-COMPOSITE
  1096.            divide temp-num1 by 2 giving temp-num2
  1097.                               remainder ACTUAL-KC-INVALIDCOMP
  1098.            divide temp-num2 by 2 giving temp-num1
  1099.                               remainder ACTUAL-KC-TOGGLE
  1100.            divide temp-num1 by 2 giving temp-num2
  1101.                               remainder ACTUAL-KC-INVALIDCHAR.
  1102.       *---------------------------------------------------------------*
  1103.        kill-focus section.
  1104.            call OS2API 'WinSubClassWindow'
  1105.                            using by value mp2
  1106.                                  by value DefEntryFieldWinProc
  1107.                            returning DefEntryFieldWinProc.
  1108.       *---------------------------------------------------------------*
  1109.        set-focus-1 section.
  1110.            move 1 to object-flag
  1111.            call OS2API 'WinSubClassWindow'
  1112.                              using by value hwndEntryField-1
  1113.                                    by value EntryFieldWinproc
  1114.                              returning DefEntryFieldWinProc.
  1115.       *---------------------------------------------------------------*
  1116.        set-focus-2 section.
  1117.            move 2 to object-flag
  1118.            call OS2API 'WinSubClassWindow'
  1119.                              using by value hwndEntryField-2
  1120.                                    by value EntryFieldWinproc
  1121.                              returning DefEntryFieldWinProc.
  1122.       *---------------------------------------------------------------*
  1123.        set-focus-3 section.
  1124.            move 3 to object-flag
  1125.            call OS2API 'WinSubClassWindow'
  1126.                              using by value hwndEntryField-3
  1127.                                    by value EntryFieldWinproc
  1128.                              returning DefEntryFieldWinProc.
  1129.       *---------------------------------------------------------------*
  1130.        set-focus-4 section.
  1131.            move 4 to object-flag
  1132.            call OS2API 'WinSubClassWindow'
  1133.                              using by value hwndEntryField-4
  1134.                                    by value EntryFieldWinproc
  1135.                              returning DefEntryFieldWinProc.
  1136.