home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 15 / CDACTUAL15.iso / cdactual / program / basic / PSCRN42.ZIP / EMPLOYEE.BAS < prev    next >
Encoding:
BASIC Source File  |  1990-08-28  |  17.5 KB  |  387 lines
  1. '******************************************************************************
  2. '*  File:          Employee.Bas                                              
  3. '*                                                                           
  4. '*  Purpose:       - 1 of 2 QuickBASIC demo programs written entirely by     
  5. '*                   P-Screen Professional (PS Pro)                          
  6. '*                 - Demonstrates several subroutines included in PS Pro:    
  7. '*                   1. rsMinput   2. rsQprint   3. FormatUsing              
  8. '*                   4. Exist      5. ProperName 6. rsCmpRst                 
  9. '*                                                                           
  10. '*  Compatibility: QuickBASIC 4.0 or higher    -OR-  PDS 7  !!
  11. '*                                                                                                               *
  12. '*  To run this:   qb employee /l ps-demo.qlb  -OR-  qbx employee /l bc7-demo
  13. '*                                                                           
  14. '*  Notes:         - Please read Routines.Doc for details on the subroutines 
  15. '*                   included with PS Pro.  These routines are in ps-demo.qlb.
  16. '*                 - After PS Pro wrote this, we did some minor editing:     
  17. '*                   -- added this intro                                     
  18. '*                   -- "hardcoded" some variables, taking them out of a loop
  19. '*                                                                           
  20. '******************************************************************************
  21.  
  22. '******************************************************************************
  23. 'Employee.Bas, written by P-Screen Professional            Date: 10-06-1989
  24.  
  25. 'NOTE: Run with QB 4.0+ -OR- PDS7 with these files in your Quick Library:
  26.        'LoadScrn, rsLoadBin, rsMinput, rsQprint, Exists, PropName & FmtUsing
  27.  
  28. 'Library = P-Screen    Screen Name = Employee               # of Fields:  18
  29. '******************************************************************************
  30.  
  31. DEFINT A-Z                             'default = Integers
  32. CONST True = -1, False = NOT True
  33.  
  34. '----Declare subs.  MUST declare QB functions.
  35.  
  36. DECLARE SUB rsMInput (Text$, ValidKeys$, Exit$, Format$, Length, RetCode, Hilite, Colr)
  37. DECLARE SUB rsQprint (Row, Column, Colr, Text$)
  38. DECLARE SUB rsLoadScrn (Array%(), LibName$, FileName$, Desc$, TopRow, TopCol, BotRow, BotCol, ScrnSize, ErrCode)
  39. DECLARE SUB rsCompRest (TopRow, BotRow, SEG Array)
  40. DECLARE SUB CompRestPlus (TopRow, TopCol, BotRow, BotCol, SEG Array)
  41. DECLARE FUNCTION FormatUsing$ (Format$, x#)  'format numbers for editing
  42. DECLARE FUNCTION Exists (FileName$)          'Exists = -1 if file DOES exist, 0 if it does NOT"
  43. DECLARE FUNCTION ProperName$ (Text$)         'convert lower case text to proper
  44.  
  45. '******************************************************************************
  46. TYPE TypeX                             'define record elements
  47.     TodaysDate       AS STRING * 16
  48.     Name1            AS STRING * 18
  49.     SocialSec1       AS STRING * 12
  50.     Hourly1          AS DOUBLE
  51.     NormalHours1     AS SINGLE
  52.     OTimeHours1      AS SINGLE
  53.     NormalWage1      AS DOUBLE
  54.     OTimeWage1       AS DOUBLE
  55.     TotalWage1       AS DOUBLE
  56.     Name2            AS STRING * 18
  57.     SocialSec2       AS STRING * 12
  58.     Hourly2          AS DOUBLE
  59.     NormalHours2     AS SINGLE
  60.     OTimeHours2      AS SINGLE
  61.     NormalWage2      AS DOUBLE
  62.     OTimeWage2       AS DOUBLE
  63.     TotalWage2       AS DOUBLE
  64.     CombinedTotal    AS DOUBLE
  65. END TYPE
  66.  
  67. DIM Employee AS TypeX
  68.  
  69. '******************************************************************************
  70. '---Alpha$ and Field Types govern which keys are considered 'Valid' by rsMInput
  71.  
  72. Alpha$ = " 1234567890-+.$%QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm=!@#^&*()_[]\{}|;':,/<>?`~" + CHR$(34)
  73. '******************************************************************************
  74.  
  75. GOSUB EditEmployee                     'get to work
  76. END
  77. '******************************************************************************
  78. EditEmployee:                          'this is what you came for
  79. '******************************************************************************
  80.  
  81. '----- Display Screen
  82. '******************************************************************************
  83.  
  84. LibName$ = "P-Screen": ScreenName$ = "Employee"
  85. GOSUB DisplayScreen
  86.  
  87. '******************************************************************************
  88. '----- Edit
  89.  
  90.    FieldNum = 1    'there are 18 fields, some may be calculated
  91.    DO              'EACH LOOP:  initialize RetCode, Exit$, & Format$
  92.  
  93.        RetCode = 32                    '32 = pad with Chr$(32)  -32 = Upper Case
  94.        Exit$ = "HP;C"                  'H = Up Cursor, P = Down Cursor, ; = F1 Help, C = F9 Calc
  95.        Format$ = ""                    'assume no mask -- an unformatted field
  96.        Minimum$ = ""                   'assume no minimum/maximum
  97.        Maximum$ = ""
  98.        ScreenName$ = "HRS/HRLY"        'Help screen for Hours/Hourly fields,
  99.                                        'the most frequently needed screen
  100.        ValidKeys$ = Alpha$             'assume any character is valid
  101.        PropName = False                'assume it's NOT a proper name field
  102.  
  103.        SELECT CASE FieldNum
  104.          CASE 1
  105.              Row = 8: Column = 39: Length = 16
  106.              ValidKeys$ = MID$(Alpha$, 1, 14)    '0-9 Only -- plus .$-+
  107.              Format$ = "## - ## - ####"
  108.              Text$ = Employee.TodaysDate
  109.              ScreenName$ = "EMPFORMT"   'Help screen for Formatted fields
  110.          CASE 2
  111.              Row = 13: Column = 1: Length = 18
  112.              PropName = True            'it IS a proper name field
  113.              Text$ = Employee.Name1
  114.              Minimum$ = "A": Maximum$ = "zzzzzzzzzzzzzzzzzzz" 'Name is REQUIRED
  115.              ScreenName$ = "EMPNAMES"   'Help screen for Formatted fields
  116.          CASE 3
  117.              Row = 13: Column = 20: Length = 12
  118.              ValidKeys$ = MID$(Alpha$, 1, 14)    '0-9 Only -- plus .$-+
  119.              Format$ = "###-##-####"
  120.              Text$ = Employee.SocialSec1
  121.              ScreenName$ = "EMPFORMT"   'Help screen for Formatted fields
  122.          CASE 4
  123.              Row = 13: Column = 33: Length = 5
  124.              ValidKeys$ = MID$(Alpha$, 1, 14)    '0-9 Only -- plus .$-+
  125.              Format$ = "##.##"
  126.              GOSUB ConvertNumber
  127.              x# = Employee.Hourly1
  128.              RSET Text$ = FormatUsing$("##.##", x#)
  129.              Format$ = ""              'don't confuse rsMinput w/ a mask
  130.              Minimum$ = "1.00": Maximum$ = "22.99"
  131.          CASE 5
  132.              Row = 13: Column = 40: Length = 5
  133.              ValidKeys$ = MID$(Alpha$, 1, 14)    '0-9 Only -- plus .$-+
  134.              Format$ = "##.##"
  135.              GOSUB ConvertNumber
  136.              x# = Employee.NormalHours1
  137.              RSET Text$ = FormatUsing$("##.##", x#)
  138.              Format$ = ""              'don't confuse rsMinput w/ a mask
  139.          CASE 6
  140.              Row = 13: Column = 47: Length = 5
  141.              ValidKeys$ = MID$(Alpha$, 1, 14)    '0-9 Only -- plus .$-+
  142.              Format$ = "##.##"
  143.              GOSUB ConvertNumber
  144.              x# = Employee.OTimeHours1
  145.              RSET Text$ = FormatUsing$("##.##", x#)
  146.              Format$ = ""              'don't confuse rsMinput w/ a mask
  147.          CASE 7
  148.              Row = 15: Column = 1: Length = 18
  149.              PropName = True            'it IS a proper name field
  150.              Text$ = Employee.Name2
  151.              Minimum$ = "A": Maximum$ = "zzzzzzzzzzzzzzzzzzz" 'Name is REQUIRED
  152.              ScreenName$ = "EMPNAMES"   'Help screen for Formatted fields
  153.          CASE 8
  154.              Row = 15: Column = 20: Length = 12
  155.              ValidKeys$ = MID$(Alpha$, 1, 14)    '0-9 Only -- plus .$-+
  156.              Format$ = "###-##-####"
  157.              Text$ = Employee.SocialSec2
  158.              ScreenName$ = "EMPFORMT"   'Help screen for Formatted fields
  159.          CASE 9
  160.              Row = 15: Column = 33: Length = 5
  161.              ValidKeys$ = MID$(Alpha$, 1, 14)    '0-9 Only -- plus .$-+
  162.              Format$ = "##.##"
  163.              GOSUB ConvertNumber
  164.              x# = Employee.Hourly2
  165.              RSET Text$ = FormatUsing$("##.##", x#)
  166.              Format$ = ""              'don't confuse rsMinput w/ a mask
  167.              Minimum$ = "1.00": Maximum$ = "22.99"
  168.          CASE 10
  169.              Row = 15: Column = 40: Length = 5
  170.              ValidKeys$ = MID$(Alpha$, 1, 14)    '0-9 Only -- plus .$-+
  171.              Format$ = "##.##"
  172.              GOSUB ConvertNumber
  173.              x# = Employee.NormalHours2
  174.              RSET Text$ = FormatUsing$("##.##", x#)
  175.              Format$ = ""              'don't confuse rsMinput w/ a mask
  176.          CASE 11
  177.              Row = 15: Column = 47: Length = 5
  178.              ValidKeys$ = MID$(Alpha$, 1, 14)    '0-9 Only -- plus .$-+
  179.              Format$ = "##.##"
  180.              GOSUB ConvertNumber
  181.              x# = Employee.OTimeHours2
  182.              RSET Text$ = FormatUsing$("##.##", x#)
  183.              Format$ = ""              'don't confuse rsMinput w/ a mask
  184.          CASE ELSE
  185.        END SELECT
  186.  
  187.        LOCATE Row, Column
  188.  
  189.        '---get color at this row/column; rsMinput takes 2 colors (Hilite, Colr to Restore)
  190.  
  191.        GOSUB GetColor
  192.  
  193.        '---use rsMinput or your own editing routine
  194.  
  195.        CALL rsMInput(Text$, ValidKeys$, Exit$, Format$, Length, RetCode, Hilite, Colr)
  196.  
  197.  
  198.        IF PropName THEN                'if it's proper name, reformat/reprint
  199.           Text$ = ProperName$(Text$)
  200.           CALL rsQprint(Row, Column, Colr, Text$)
  201.        END IF
  202.  
  203.        IF RetCode = -27 THEN EXIT DO   'Esc pressed, exit
  204.  
  205.        GOSUB Validate                  'validate against range you specified
  206.  
  207.        IF Invalid AND RetCode% <> 3 THEN
  208.            BEEP
  209.        ELSE
  210.            SELECT CASE RetCode         'RetCode = position in Exit$
  211.                                        '1 = Up Cursor, 2 = Down Cursor, 3 = F1 Help, 4 = F9 Calc
  212.              CASE 1                    'UP cursor
  213.                  FieldNum = FieldNum - 1: IF FieldNum < 1 THEN FieldNum = 11
  214.              CASE 3                    'F1 Help
  215.                  GOSUB DisplayScreen   'display help screen.  Beep = Error
  216.              CASE 4                    'F9 Calc
  217.                  GOSUB DoCalcs         'calculate your formulas, print results
  218.              CASE ELSE                 'move forward on <cr> or DOWN cursor
  219.                  FieldNum = FieldNum + 1
  220.                  IF FieldNum > 11 THEN GOSUB DoCalcs: FieldNum = 1
  221.            END SELECT
  222.        END IF
  223.  
  224.    LOOP UNTIL RetCode = -27            'exit on Esc
  225.  
  226. RETURN
  227. '******************************************************************************
  228.  
  229. '******************************************************************************
  230. GetColor:                              'get colors at this Row, Column
  231. '******************************************************************************
  232.    IF Row < 1 OR Column < 1 THEN BEEP: Colr = 7: Hilite = 112: RETURN
  233.                                        'avoid Illegal Function Call
  234.        Colr = SCREEN(Row, Column, -1)  'get color at this Row/Column
  235.        Fore = (Colr MOD 16): Back = (((Colr - Fore) / 16) MOD 128)
  236.        Hilite = (Fore AND 7) * 16 + Back + (Back AND 16) * 7
  237.                                        'reverse color for editing
  238. RETURN
  239. '******************************************************************************
  240.  
  241. '******************************************************************************
  242. DisplayScreen:                         'Display MAIN and HELP Screens
  243. '******************************************************************************
  244.    IF LibName$ = "" OR ScreenName$ = "" THEN BEEP: RETURN
  245.  
  246.    IF Exists(LibName$ + ".PSL") AND RTRIM$(ScreenName$) > "" THEN
  247.        REDIM Array%(1)                 'initialize INTEGER screen array
  248.        CALL rsLoadScrn(Array%(), LibName$, ScreenName$, Desc$, TopRow, TopCol, BotRow, BotCol, x, ErrCode)
  249.    ELSE ErrCode = -1
  250.    END IF
  251.  
  252.    IF ErrCode < 1 THEN BEEP: RETURN    'must have been an error
  253.  
  254.    CALL CompRestPlus(TopRow, TopCol, BotRow, BotCol, SEG Array%(1)): ERASE Array
  255.  
  256. RETURN
  257. '******************************************************************************
  258.  
  259. '******************************************************************************
  260. Validate:                              'Validate input against ranges you specified
  261. '******************************************************************************
  262. '----trap 'Invalid Number' errors, as when width of your field is too narrow
  263.    IF LEN(Text$) > 0 AND MID$(Text$, 1, 1) = "%" THEN MID$(Text$, 1, 1) = CHR$(32)
  264.    IF LEN(Text$) > 0 AND MID$(Text$, 1, 1) = "$" THEN MID$(Text$, 1, 1) = CHR$(32)
  265.  
  266.    Text$ = RTRIM$(Text$)
  267.  
  268.    Invalid = 0                         'assume it's valid
  269.  
  270.    IF Minimum$ > "" AND Maximum$ > "" THEN
  271.        SELECT CASE FieldNum            'if Text...
  272.            CASE 2, 7                   'it's a Text field
  273.              IF Text$ < Minimum$ OR Text$ > Maximum$ THEN Invalid = -1
  274.            CASE ELSE                   'it's a Numeric field
  275.              x# = VAL(Text$)
  276.              IF x# < VAL(Minimum$) OR x# > VAL(Maximum$) THEN Invalid = -1
  277.        END SELECT
  278.    END IF
  279.  
  280.    IF Invalid THEN RETURN              'it's valid, don't assign
  281.  
  282.    SELECT CASE FieldNum
  283.        CASE 1: Employee.TodaysDate = Text$
  284.        CASE 2: Employee.Name1 = Text$
  285.        CASE 3: Employee.SocialSec1 = Text$
  286.        CASE 4: Employee.Hourly1 = VAL(Text$)
  287.        CASE 5: Employee.NormalHours1 = VAL(Text$)
  288.        CASE 6: Employee.OTimeHours1 = VAL(Text$)
  289.        CASE 7: Employee.Name2 = Text$
  290.        CASE 8: Employee.SocialSec2 = Text$
  291.        CASE 9: Employee.Hourly2 = VAL(Text$)
  292.        CASE 10: Employee.NormalHours2 = VAL(Text$)
  293.        CASE 11: Employee.OTimeHours2 = VAL(Text$)
  294.    CASE ELSE
  295.    END SELECT
  296.  
  297. RETURN
  298. '******************************************************************************
  299.  
  300. '******************************************************************************
  301. ConvertNumber:     'set length of Text$ equal to # of valid positions in mask; inc. '.'
  302. '******************************************************************************
  303.    IF LEN(Format$) < 1 THEN Text$ = SPACE$(Length): RETURN
  304.  
  305.    NumberSpaces = 0
  306.    FOR x = 1 TO LEN(Format$)
  307.        IF INSTR("#ยท.", MID$(Format$, x, 1)) THEN NumberSpaces = NumberSpaces + 1
  308.    NEXT
  309.    Text$ = SPACE$(NumberSpaces)
  310.  
  311. RETURN
  312. '******************************************************************************
  313.  
  314. '******************************************************************************
  315. DoCalcs:           'Do calculations.  Delete this if none.
  316. '******************************************************************************
  317.  
  318. '---- Calculate: Employee.NormalWage1
  319.    Employee.NormalWage1 = Employee.Hourly1 * Employee.NormalHours1
  320.    Row = 13: Column = 53: Length = 8
  321.    x# = Employee.NormalWage1           'FormatUsing needs DOUBLE Prec.
  322.    Temp$ = SPACE$(Length)
  323.    RSET Temp$ = FormatUsing$("$$###.##", x#) 'RSet to allign decimals, etc.
  324.    GOSUB GetColor
  325.    CALL rsQprint(Row, Column, Colr, Temp$)
  326.  
  327. '---- Calculate: Employee.OTimeWage1
  328.    Employee.OTimeWage1 = (Employee.Hourly1 * 1.5) * Employee.OTimeHours1
  329.    Row = 13: Column = 62: Length = 8
  330.    x# = Employee.OTimeWage1            'FormatUsing needs DOUBLE Prec.
  331.    Temp$ = SPACE$(Length)
  332.    RSET Temp$ = FormatUsing$("$$###.##", x#) 'RSet to allign decimals, etc.
  333.    GOSUB GetColor
  334.    CALL rsQprint(Row, Column, Colr, Temp$)
  335.  
  336. '---- Calculate: Employee.TotalWage1
  337.    Employee.TotalWage1 = Employee.NormalWage1 + Employee.OTimeWage1
  338.    Row = 13: Column = 71: Length = 10
  339.    x# = Employee.TotalWage1            'FormatUsing needs DOUBLE Prec.
  340.    Temp$ = SPACE$(Length)
  341.    RSET Temp$ = FormatUsing$("$#####,.##", x#)
  342.                                        'RSet to allign decimals, etc.
  343.    GOSUB GetColor
  344.    CALL rsQprint(Row, Column, Colr, Temp$)
  345.  
  346. '---- Calculate: Employee.NormalWage2
  347.    Employee.NormalWage2 = Employee.Hourly2 * Employee.NormalHours2
  348.    Row = 15: Column = 53: Length = 8
  349.    x# = Employee.NormalWage2           'FormatUsing needs DOUBLE Prec.
  350.    Temp$ = SPACE$(Length)
  351.    RSET Temp$ = FormatUsing$("$$###.##", x#) 'RSet to allign decimals, etc.
  352.    GOSUB GetColor
  353.    CALL rsQprint(Row, Column, Colr, Temp$)
  354.  
  355. '---- Calculate: Employee.OTimeWage2
  356.    Employee.OTimeWage2 = (Employee.Hourly2 * 1.5) * Employee.OTimeHours2
  357.    Row = 15: Column = 62: Length = 8
  358.    x# = Employee.OTimeWage2            'FormatUsing needs DOUBLE Prec.
  359.    Temp$ = SPACE$(Length)
  360.    RSET Temp$ = FormatUsing$("$$###.##", x#) 'RSet to allign decimals, etc.
  361.    GOSUB GetColor
  362.    CALL rsQprint(Row, Column, Colr, Temp$)
  363.  
  364. '---- Calculate: Employee.TotalWage2
  365.    Employee.TotalWage2 = Employee.NormalWage2 + Employee.OTimeWage2
  366.    Row = 15: Column = 71: Length = 10
  367.    x# = Employee.TotalWage2            'FormatUsing needs DOUBLE Prec.
  368.    Temp$ = SPACE$(Length)
  369.    RSET Temp$ = FormatUsing$("$#####,.##", x#)
  370.                                        'RSet to allign decimals, etc.
  371.    GOSUB GetColor
  372.    CALL rsQprint(Row, Column, Colr, Temp$)
  373.  
  374. '---- Calculate: Employee.CombinedTotal
  375.    Employee.CombinedTotal = Employee.TotalWage1 + Employee.TotalWage2
  376.    Row = 18: Column = 68: Length = 13
  377.    x# = Employee.CombinedTotal         'FormatUsing needs DOUBLE Prec.
  378.    Temp$ = SPACE$(Length)
  379.    RSET Temp$ = FormatUsing$("$#####,.##", x#)
  380.                                        'RSet to allign decimals, etc.
  381.    GOSUB GetColor
  382.    CALL rsQprint(Row, Column, Colr, Temp$)
  383.  
  384. RETURN
  385. '******************************************************************************
  386.  
  387.