home *** CD-ROM | disk | FTP | other *** search
/ DTP Toolbox / DTPToolbox.iso / propage4.0 / arexx / makecalendar.pprx < prev    next >
Encoding:
Text File  |  1992-08-26  |  13.8 KB  |  525 lines
  1. /*
  2. @BMakeCalendar  @P@Iby Robin Evans, April/August, 1992
  3. Creates a calendar for the specified month and year
  4. */
  5.  
  6. signal on halt
  7. signal on break_c
  8. signal on break_e
  9. signal on break_d
  10.  
  11. call ppm_ShowStatus("MakeCalendar")
  12. call SafeEndEdit.rexx()
  13. call ppm_AutoUpdate(0)
  14. cr  = '0a'x
  15.  
  16. units = ppm_GetUnits()
  17. call ppm_SetUnits(2)
  18.  
  19. page    = ppm_CurrentPage()
  20. if page = 0 then
  21.     exit_msg("Create Page First")
  22.  
  23. IsBox = ppm_PageFirstBox(page)
  24. if IsBox == 0 then
  25.     exit_msg("Create box to hold calendar")
  26.  
  27. OrgBox = ppm_ClickOnBox("Click on box to contain calendar")
  28. if box = 0 then
  29.     exit_msg()
  30. else
  31.     if upper(word(ppm_GetBoxInfo(OrgBox), 1)) ~= 'EMPTY' then
  32.         exit_msg("Box must be empty.")
  33.  
  34.  
  35. PrefForm = ppm_GetForm("Calendar preferences", 10, SetPrefs())
  36. if PrefForm = '' then
  37.     exit_msg('Aborted.')
  38. else
  39.     PrefStore = PrefForm
  40.  
  41.  
  42. call ppm_ShowStatus("MakeCalendar.")
  43.  
  44.     /* Color lists are used to check input on the requester */
  45. parse value ppm_GetColorList() with . '0a'x ColorList
  46. ColorStr = translate(upper(ColorList), ' ', '0a'x)
  47.  
  48. do i = 1 to PrefType.NumPrefs
  49.     parse var PrefForm value '0a'x PrefForm
  50.     interpret word(PrefType.i.com, 2) '=' word(PrefType.i.com, 1)'("'value'",'i')'
  51. end
  52.  
  53. if year < 51 then
  54.     year = year + 2000
  55. else
  56.     if year < 100 & year > 49 then year = 1900 + year
  57.  
  58.  
  59. call ppm_ShowStatus("MakeCalendar..")
  60.  
  61. parse value ppm_getboxsize(OrgBox) with bWid OrgHi .
  62. parse value ppm_getboxposition(OrgBox) with bLeft OrgTop .
  63.  
  64.     /* Calculate size of font for month/year Title bar and of Calendar box*/
  65. FTitleSize = OrgHi/18
  66.  
  67. bHi = OrgHi - FTitleSize
  68. bTop = OrgTop + FTitleSize
  69. bRight = bLeft + bWid
  70. bBot = bTop + bHi
  71. cwidth  = bWid / 7
  72. rheight = bHi / 5
  73.  
  74. if bHi < 8 & MemoFld then do
  75.     if ppm_Inform(2, "Box is too small"'0a'x"for memos", ' Cancel ', '  Okay  ') == 1 then
  76.         MemoFld = 0
  77.     else
  78.         exit_msg('Aborted.')
  79. end
  80.  
  81. DateFont = ppm_SelectFromList("Choose font for dates", 32, 8, 0, FontList.rexx(ppm_GetFont()))
  82. if DateFont = '' then exit_msg()
  83. if memoFld then
  84.     MemoFont = ppm_SelectFromList("Choose font for memos", 32, 8, 0, FontList.rexx(ppm_GetFont()))
  85.  
  86.     /* Create box for month/year Title bar */
  87. TitleBox = CreateBox(bLeft, OrgTop, bWid, FTitleSize + FTitleSize * .9, 0, 'TitleBox')
  88.  
  89.     /* reset the original box below the title box */
  90. call ppm_setboxsize(OrgBox, bWid, bHi)
  91. call ppm_setboxposition(OrgBox, bLeft, bTop)
  92.  
  93.     /* Add month & year to title bar */
  94. call ppm_ShowStatus("MakeCalendar...")
  95. call ppm_BoxNum(TitleBox)     /* Make it the active box */
  96. TSize = ppm_SetSize(PPtoPoints(ppm_ConvertUnits(2,3, FTitleSize)))
  97. call ppm_SetFont(DateFont)
  98. call ppm_SetTextColor(TColor)
  99. call ppm_SetLineSpacing(0, -TSize)
  100. if TBold then
  101.     setB = '\B'
  102. else
  103.     setB = '\b'
  104. call ppm_TextIntoBox(TitleBox, setB'\jl' || word(monthWords, IntMonth) || '0a'x'\jr'Year)
  105.  
  106.  
  107.     /* Prepare original box for date numerals */
  108.  
  109. call ppm_ShowStatus("MakeCalendar....")
  110.  
  111. call ppm_BoxNum(OrgBox)     /* Make it the active box */
  112. call ppm_SetBoxFrame(OrgBox, 0)
  113.  
  114.     /* Calculate and set text size and leading for dates */
  115. FontMeasure = min(rheight, cwidth)
  116. LittleFont = max(.3528, FontMeasure / 4)
  117. BigFont = max(.3528, FontMeasure / 1.5)
  118. if SmallFont then
  119.     DSizeCM = LittleFont
  120. else
  121.     DSizeCM = BigFont
  122.  
  123. DSize = ppm_SetSize(PPtoPoints(ppm_ConvertUnits(2,3, DSizeCM)))
  124. call ppm_SetFont(DateFont)
  125.  
  126. Dlead = PPtoPoints(ppm_ConvertUnits(2,3, rheight - DSizeCM)) + 1
  127. call ppm_SetLineSpacing(0, DLead)
  128.  
  129. call ppm_SetTextColor(DColor)
  130.  
  131.     /* Set the left margin (which will come close to centering most fonts) */
  132. if SmallFont then do
  133.     TMarg = max(.0705, DSizeCM / 15)
  134.     LMarg = TMarg
  135. end
  136. else do
  137.     TMarg = DSizeCM / 2.8
  138.     LMarg = max(min(.3, CWidth / 6), CWidth - DSizeCM * 1.4)
  139.     call ppm_setboxsize(OrgBox, bWid + TMarg, bHi + TMarg)
  140. end
  141. call ppm_SetBoxMargins(OrgBox, LMarg, TMarg, 0, 0)
  142. call ppm_SetBoxName(OrgBox, "Calendar dates")
  143.  
  144. DateTabs = cwidth
  145. do i = 2 to 16
  146.     DateTabs = DateTabs cWidth * i
  147. end
  148. call ppm_SetBoxTabs(OrgBox, DateTabs)
  149.  
  150.     /*    Calculate the date and build a string. Prepare original box for date
  151.         string and insert it.
  152.     */
  153.  
  154. call ppm_ShowStatus("MakeCalendar.....")
  155. oFlow = CalendarText(IntMonth Year)
  156.  
  157. call ppm_ShowStatus("Adding dates to calendar.")
  158.  
  159. if DBold then
  160.     setB = '\B'
  161. else
  162.     setB = '\b'
  163. call ppm_TextIntoBox(OrgBox, setB'\jl'DayStr)
  164.  
  165.     /*    Create a grid the size of the chosen box */
  166.  
  167. call ppm_ShowStatus("Creating calendar grid.")
  168.  
  169. columns = 6
  170. rows = 4            /* Count from 0 */
  171. oldlc   = ppm_GetLineColor()
  172. call ppm_SetLineColor(GColor)
  173.     /* error */
  174. call ppm_SetLineWeight(LineWeight)
  175. call ppm_SetFillPattern(0)
  176.  
  177. call ppm_NewGroup()
  178. firstbox = ppm_DrawRect(bLeft, bTop, bRight, bBot)
  179. call ppm_AddToGroup(firstbox)
  180. call ppm_SetBoxFrame(firstbox, 0)
  181.  
  182.     /* Now put the grid lines into the rectangle */
  183. do i = 1 to columns
  184.     xLine = bLeft + (cWidth * i)
  185.     box = ppm_DrawLine(xLine, bTop, xLine, bBot)
  186.     call ppm_AddToGroup(box)
  187. end
  188. do i = 1 to rows
  189.     yLine = bTop + (rHeight * i)
  190.     box = ppm_DrawLine(bLeft, yLine, bRight, yLine)
  191.     call ppm_AddToGroup(box)
  192. end
  193.  
  194. oTop = bTop + rHeight * 4
  195. do i = 1 for oFlow    /* Add diagonal & text for overflow days */
  196.     call ppm_SetLineColor(GColor)    /* Loses color on second line */
  197.     oleft = bLeft + (i - 1) * cWidth
  198.     box = ppm_DrawLine(oLeft, oTop + rHeight, oleft + cWidth, oTop)
  199.     call ppm_AddToGroup(box)
  200.     OFlowBox.i = ppm_CreateBox(oLeft, oTop, cWidth, rHeight, 0, 'OFlow' i)
  201.     OFSize = ppm_SetSize(DSize/1.8)
  202.     call ppm_SetFont(DateFont)
  203.         /* Calculate and set leading */
  204.     call ppm_BoxNum(OFlowBox.i)
  205.     Olead = PPtoPoints(ppm_ConvertUnits(2,3, rheight)) - (OFSize * 2 + PPtoPoints(ppm_ConvertUnits(2,3,TMarg))) - 2
  206.     call ppm_SetLineSpacing(0, OLead)
  207.     call ppm_SetBoxMargins(OFlowBox.i, LMarg/2, TMarg, LMarg/2, 0)
  208.     if DBold then
  209.         setB = '\B'
  210.     else
  211.         setB = '\b'
  212.     call ppm_TextIntoBox(OFlowBox.i, setB'\jl' || months.IntMonth.days - oFlow + i - 7 '0a'x'\jr' || months.IntMonth.days - oFlow + i)
  213. end
  214.  
  215. call ppm_SetLineColor(oldlc)
  216. GridBox =  ppm_MergeGroup()
  217. call ppm_BoxToBack(GridBox)
  218. /* call ppm_SetBoxLock(GridBox, 1)*/
  219. call ppm_SetBoxName(GridBox, "Calendar grid")
  220.  
  221.     /* Add boxes for memos to each date */
  222. if MemoFld then do
  223.     call ppm_ShowStatus("Adding memo boxes.")
  224.  
  225.     OrgMemo = ppm_CreateBox(bLeft, bTop, cWidth, rHeight, 0,)
  226.     call ppm_SetBoxFrame(OrgMemo, 0)
  227.     call ppm_SetSize(max(9, DSize/2))
  228.     call ppm_SetFont(MemoFont)
  229.     call ppm_SetLineSpacing(2, 110)
  230.     call ppm_SetBoxMargins(OrgMemo, .0705, DSizeCM, .0705, 0)
  231.     call ppm_SetTextColor('Black')
  232.  
  233.     xoffset = 0
  234.     yoffset = 0
  235.    MonthShort = left(months.IntMonth, 3)
  236.  
  237.     do  i = 0 to rows
  238.         do col = 0 to columns
  239.             MemNum = (i * 7) + col + 1
  240.             MemoBox.MemNum = ppm_CloneBox(OrgMemo, xoffset, yoffset)
  241.             date = max(0, memNum - firstdaynum)
  242.             call ppm_SetBoxName(MemoBox.MemNum,  daynames.col MonthShort date)
  243.             xoffset = xoffset + cWidth
  244.         end
  245.         yoffset = yoffset + rheight
  246.         xoffset = 0
  247.     end
  248.     call ppm_DeleteBox(OrgMemo)    /* we've put another one on top w/ name */
  249. end
  250.  
  251. call setclip('ppg_CalPrefs', PrefStore)
  252. exit_msg()
  253.  
  254.  
  255.     /*******************************************************************
  256.         Functions
  257.     ==================================================================*/
  258.  
  259.     Calendar functions.
  260.     Most of the calendar functions below are borrowed from the program
  261.     calendar.rexx by
  262.     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*/
  263.  
  264. /**
  265. *
  266. *  This subroutine, borrowed from code written by Mike Meyer and
  267. *  distributed on an early ARexx disk, creates textstring used in
  268. *  the calendar
  269. *
  270. **/
  271.  
  272. CalendarText: procedure expose firstdaynum DayStr Daynames. Months. year
  273.     arg mymonth myyear
  274.    /*
  275.    *  Call the subroutine jan1() to get the day of the week
  276.    *  that the year started on.
  277.    */
  278.     call ppm_ShowStatus("Calculating dates.")
  279.    call setdefs
  280.    firstday = jan1(myyear)
  281.    /*
  282.    *  Now fix up the months. array to reflect the correct
  283.    *  number of days in February for this year.
  284.    *  This is done by getting the day of the week on
  285.    *  which jan1 occurs for the next year and doing
  286.    *  some simple arithmetic to calculate a fudge factor.
  287.    *  NOTE the use of REXX's modular arithmetic operator //
  288.    *  and that something funny happens in 1752 when the calendar
  289.    *  changes:
  290.    *
  291.    *     fudge = 1  --> regular year
  292.    *     fudge = 2  --> leap year
  293.    *     otherwise  --> 1752
  294.    */
  295.    fudge = (jan1(myyear + 1) + 7 - firstday) // 7
  296.  
  297.    select
  298.       when fudge = 1 then months.2.days = 28
  299.       when fudge = 2 then months.2.days = 29
  300.       otherwise
  301.          months.2.days = 29
  302.          months.9.days = 19
  303.    end
  304.  
  305.    do i = 1 to mymonth - 1
  306.       firstday = firstday + months.i.days
  307.    end
  308.    /*
  309.    *  Next compute the day of the week and its name
  310.    */
  311.    firstdaynum = firstday // 7
  312.        /*  Get number of days in this month   */
  313.    days = months.mymonth.days
  314.  
  315.         /* Will the days take more than 5 rows? */
  316.     overflow = max(0, (firstdaynum + days) - 35)
  317.  
  318.         /*    Build a tab-delimited string of the dates in the month */
  319.     dayStr = ''
  320.     do for firstdaynum
  321.         dayStr = dayStr || '09'x    /* Blanks at start of calendar */
  322.     end
  323.     do i = 1 to 9
  324.         dayStr = dayStr || '\T' i || '09'x /* Add space to justify */
  325.     end
  326.     do i = 10 to 28 - firstdaynum        /* first 4 rows */
  327.         dayStr = dayStr || i || '09'x
  328.     end
  329.     do for overflow
  330.         dayStr = dayStr || '09'x
  331.     end
  332.     i = i + overflow
  333.     lday = days - overflow
  334.     do li = i to lday
  335.         dayStr = dayStr || li || '09'x
  336.     end
  337.  
  338. return overflow
  339.  
  340. /**
  341. *  returns the day of the week that january first falls on for
  342. *  any specific year, 1 through 9999 (assuming they don't change
  343. *  the rules again).
  344. **/
  345. jan1: procedure
  346.    arg year
  347.  
  348.    /*
  349.    *  Julian calendar; one extra day every four years
  350.    *  Gregorian calendar - lose three days over four centuries
  351.    *  And there was an instant changeover in 1752
  352.    *  Note the use of REXX's  % and // operators to do modular
  353.    *  arithmetic.
  354.    */
  355.    day = 4 + year + (year + 3) % 4
  356.    if year > 1800 then
  357.    do
  358.       day = day - (year - 1701) % 100
  359.       day = day + (year - 1601) % 400
  360.    end
  361.    if year > 1752 then
  362.       day = day + 3
  363. return day // 7
  364.  
  365. /*
  366. *  Set up a stem variable to contain info about
  367. *  months used to format the calendar.
  368. *  Also set up a stem variable which contains strings
  369. *  used as day names
  370. */
  371. SetDefs:
  372.    months.1 = 'January'
  373.    months.1.days = 31
  374.    months.2 = 'February'
  375.    months.2.days = 1   /* Fixed later */
  376.    months.3 = 'March'
  377.    months.3.days = 31
  378.    months.4 = 'April'
  379.    months.4.days = 30
  380.    months.5 = 'May'
  381.    months.5.days = 31
  382.    months.6 = 'June'
  383.    months.6.days = 30
  384.    months.7 = 'July'
  385.    months.7.days = 31
  386.    months.8 = 'August'
  387.    months.8.days = 31
  388.    months.9 = 'September'
  389.    months.9.days = 30
  390.    months.10 = 'October'
  391.    months.10.days = 31
  392.    months.11 = 'November'
  393.    months.11.days = 30
  394.    months.12 = 'December'
  395.    months.12.days = 31
  396.  
  397.    daynames.0 = 'Sun'
  398.    daynames.1 = 'Mon'
  399.    daynames.2 = 'Tue'
  400.    daynames.3 = 'Wed'
  401.    daynames.4 = 'Thu'
  402.    daynames.5 = 'Fri'
  403.    daynames.6 = 'Sat'
  404. return
  405.  
  406.     /*    Find the integer value for the specified month */
  407. TranMonth: procedure expose monthWords units
  408.     arg monthV, pnum
  409.     monthWords = 'JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER'
  410.     if ~datatype(MonthV, 'N') & length(MonthV) ~== 0 then do
  411.         Month = find(monthWords, MonthV)
  412.         if Month == 0 then do
  413.             Month = index(monthWords, MonthV)
  414.                 /* Now get the whole name of month from the abbreviation */
  415.             if Month > 0 then do
  416.                 parse value substr(monthWords, Month, 12) with MonthV .
  417.                 Month = find(monthWords, MonthV)
  418.             end
  419.         end
  420.     end
  421.     else
  422.         Month = MonthV
  423.     if Month > 0 & Month < 13 then
  424.         return Month
  425.     else
  426.         exit_Msg('Improper format: Month')
  427.  
  428. VerifyNumber: procedure expose PrefType. units
  429.     arg number, pnum
  430.  
  431.     if ~datatype(number, n) then exit_msg("Invalid input:" PrefType.pnum)
  432.     return(number)
  433.  
  434.  
  435. YNtoNumber: procedure expose PrefType. units
  436.     arg value, pnum
  437.  
  438.     select
  439.         when value = '' then return(0)
  440.        when abbrev(value,'Y') then return(1)
  441.        when abbrev(value,'N') then return(0)
  442.        otherwise call exit_msg("Invalid entry:" PrefType.pnum)
  443.     end
  444.  
  445. CheckColor: procedure expose PrefType. units ColorList ColorStr PrefStore
  446.  
  447.     parse arg value, pnum
  448.         /* need 'parse above and 'upper' below to keep value correct case for
  449.             the parse command when storing a new value    */
  450.     if value == '' | pos(upper(value), ColorStr) == 0 then do
  451.         OldVal = '0a'x || Value || '0a'x
  452.         Value = ppm_selectFromList('Pick' Preftype.pnum, 25, 15, 0, ColorList)
  453.         if Value = '' then
  454.             exit_msg('Aborted.')
  455.         else do
  456.                 /* Store the new value */
  457.             interpret 'parse var PrefStore PreStore' pos(OldVal, PrefStore) '. +'length(OldVal) 'PostStore'
  458.             PrefStore = PreStore || '0a'x || Value || '0a'x || PostStore
  459.         end
  460.     end
  461.     return Value
  462.  
  463. SetPrefs: procedure expose PrefType.
  464.  
  465.     cr = '0a'x
  466.     PrefForm = ''
  467.     PrefType = ''
  468.     PrefType.NumPrefs = 10
  469.     PrefType.1 = 'Month'
  470.     PrefType.1.com = 'TranMonth IntMonth'
  471.     PrefType.2 = 'Year'
  472.     PrefType.2.com = 'verifynumber Year'
  473.     PrefType.3 = 'Title color'
  474.     PrefType.3.com = 'CheckColor TColor'
  475.     PrefType.4= 'Date color'
  476.     PrefType.4.com= 'CheckColor DColor'
  477.     PrefType.5 = 'Grid Color'
  478.     PrefType.5.com = 'CheckColor GColor'
  479.     PrefType.6 = 'Line weight'
  480.     PrefType.6.com = 'verifynumber LineWeight'
  481.     PrefType.7 = 'Bold dates (y/n)?'
  482.     PrefType.7.com = 'yntonumber DBold'
  483.     PrefType.8 = 'Bold title (y/n)?'
  484.     PrefType.8.com = 'yntonumber TBold'
  485.     PrefType.9 = 'Memo boxes (y/n)?'
  486.     PrefType.9.com = 'yntonumber MemoFld'
  487.     PrefType.10 = 'Small font (y/n)?'
  488.     PrefType.10.com = 'yntonumber SmallFont'
  489.  
  490.     PrefVal = getclip('ppg_CalPrefs')
  491.     if PrefVal == '' then
  492.         PrefVal = cr||cr||'Black'cr'Black'cr'Black'cr'1.0'cr'n'cr'n'cr'n'cr'n'
  493.     do i = 1 to PrefType.NumPrefs
  494.         parse var PrefVal Val '0a'x PrefVal
  495.         PrefForm = PrefForm || PrefType.i' :'Val || cr
  496.     end
  497.  
  498.  
  499. return strip(PrefForm,T, cr)    /* take off trailing cr */
  500.  
  501. PPtoPoints:    procedure         /* convert points and picas to points */
  502. arg PPs
  503.     parse var PPs Picas '.' Points
  504.     Points = Points + Picas * 12
  505. return points
  506.  
  507. break_d:
  508. break_e:
  509. break_c:
  510. halt:
  511.     call exit_msg("User aborted Genie!")
  512.  
  513. exit_msg:
  514.    parse arg message
  515.  
  516.     call ppm_ClearStatus()
  517.  
  518.    if message ~= '' then
  519.        call ppm_Inform(1, message,)
  520.  
  521.    call ppm_SetUnits(units)
  522.    call ppm_ClearStatus()
  523.    call ppm_AutoUpdate(1)
  524.    exit
  525.