! Main program for sample Calendar program ! ! Demonstrates the use of the QuickWin library, displaying a graphical ! monthly calendar for the current month. ! ! Create the project as a QuickWin application so that the proper libraries ! are linked in. ! program Calendar USE Calendar_Mod !Data Module USE DFLIB USE DFNLS INTEGER(2) fontnum, numfonts INTEGER(4) cp type (xycoord) pos character*50 lang, country INTEGER(4) i4 TYPE (qwinfo) qw OPEN(3, file='user', title='Calendar QuickWin Fortran example') ! Clear the screen to the background color. i4 = setbkcolor(BackColor) call clearscreen($GCLEARSCREEN) ! Get the application's child window. i4 = getwsizeqq(3,QWIN$SIZECURR, qw) ! maximize it. qw.type = QWIN$MAX i4 = setwsizeqq(3, qw) ! Get the local information. This could be used to customize ! the fonts and text. The program does use locale-specific ! text for month and day numbers and regional settings for ! date formats. ! call NLSGetLocale(lang, country, cp) ! get Locale information !+++++++ Initialize Font numfonts = INITIALIZEFONTS ( ) fontnum = SETFONT ('t''Arial''h18b') ! Display local language and country information ! CALL MOVETO (INT4(10), INT4(30), pos) CALL OUTGTEXT('Language:') CALL MOVETO (INT2(100), INT2(30), pos) CALL OUTGTEXT(lang) CALL MOVETO(INT2(210), INT2(30), pos) CALL OUTGTEXT('Country :') CALL MOVETO (INT2(300), INT2(30), pos) CALL OUTGTEXT(country) CALL PRINTTHISMONTH() ! Loop forever do while (.TRUE.) end do END !+++++++++++++++++++++++++++++++++++++++++++++++++ ! InitialSettings ( ) ! LOGICAL(4) FUNCTION InitialSettings() USE DFLIB USE DFNLS LOGICAL(4) l4 integer(4) cp call NLSGetLocale(CODEPAGE = cp) ! This routine is called automatically when the program begins. It sets ! up the menu structure for the program, and connects "callback" routines ! with each menu item. l4 = appendmenuqq(1, $MENUENABLED, 'File'C, NUL) l4 = appendmenuqq(1, $MENUENABLED, 'Print...'C, WINPRINT) l4 = appendmenuqq(1, $MENUENABLED, 'Save...'C, WINSAVE) l4 = appendmenuqq(1, $MENUENABLED, 'Exit'C, WINEXIT) l4 = appendmenuqq(2, $MENUENABLED, 'Edit'C, NUL) l4 = appendmenuqq(2, $MENUENABLED, 'Select Text'C, WINSELECTTEXT) l4 = appendmenuqq(2, $MENUENABLED, 'Select Graphics'C,WINSELECTGRAPHICS) l4 = appendmenuqq(2, $MENUENABLED, 'Select All'C, WINSELECTALL) l4 = appendmenuqq(2, $MENUENABLED, 'Copy'C, WINCOPY) l4 = appendmenuqq(2, $MENUENABLED, 'Paste'C, WINPASTE) l4 = appendmenuqq(3, $MENUENABLED, 'View'C, NUL) l4 = appendmenuqq(3, $MENUENABLED, 'Size to Fit'C, WINSIZETOFIT) l4 = appendmenuqq(3, $MENUENABLED, 'Full Screen'C, WINFULLSCREEN) l4 = appendmenuqq(4, $MENUENABLED, 'State'C, NUL) l4 = appendmenuqq(4, $MENUENABLED, 'Pause'C, WINSTATE) l4 = appendmenuqq(5, $MENUENABLED, 'Window'C, NUL) l4 = appendmenuqq(5, $MENUENABLED, 'Cascade'C, WINCASCADE) l4 = appendmenuqq(5, $MENUENABLED, 'Tile'C, WINTILE) l4 = appendmenuqq(5, $MENUENABLED, 'Arrange Icons'C, WINARRANGE) l4 = appendmenuqq(5, $MENUENABLED, 'Clear Paste'C, WINCLEARPASTE) l4 = appendmenuqq(5, $MENUENABLED, 'Status Bar'C, WINSTATUS) l4 = appendmenuqq(6, $MENUENABLED, 'Help'C, NUL) l4 = appendmenuqq(6, $MENUENABLED, 'Using Help'C, WINUSING) l4 = appendmenuqq(6, $MENUENABLED, 'About'C, WINABOUT) InitialSettings = l4 return end !+++++++++++++++++++++++++++++++++++++++++++++++++ ! PrintBox ( ) ! box : 0,1,2, ... ! subroutine PrintBox(box, day) USE Calendar_Mod !Data Module USE DFLIB INTEGER(2) box, col, row, day, color type (xycoord) pos row = box / 7 col = mod(box, 7) i4 = setcolorrgb(GridColor) i4 = rectangle( $GBORDER, Calendar(col+1)%numx, & ColYOff*row+Calendar(col+1)%numy, & Calendar(col+1)%numx+ColXOff, & ColYOff*row+Calendar(col+1)%numy+ColYOff ) if (day > 0) then SELECT CASE (mod(box,7)) CASE (0) color = WeekendColor CASE (1) color = WeekdayColor CASE (2) color = WeekdayColor CASE (3) color = WeekdayColor CASE (4) color = WeekdayColor CASE (5) color = WeekdayColor CASE (6) color = WeekendColor CASE DEFAULT color = WeekendColor END SELECT i4 = setcolorrgb(color) CALL MOVETO(Calendar(col+1)%numx+3, ColYOff*row+Calendar(col+1)%numy+3,pos) CALL OUTGTEXT(DayString(day)) end if end subroutine !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++= ! PRINTTHISMONTH( ) ! ! subroutine PRINTTHISMONTH() USE Calendar_Mod !Data Module USE DFLIB USE DFNLS character*8 date character*10 time character*5 zone character*50 str INTEGER(4) DateTime(8), tm, cp INTEGER(4) DaysInMonth INTEGER(2) day, day1st, box, color INTEGER(2) fontnum type (xycoord) pos ! Get locale, could change output based on codepage returned ! call NLSGetLocale(CODEPAGE = cp) ! Get today's date and time using Fortran 90 intrinsic. Convert to ! format of date as specified by user's regional settings ! i4 = setcolorrgb(TextColor) call date_and_time(date, time, zone, DateTime) call PackTimeQQ(tm, INT2(DateTime(1)), INT2(DateTime(2)),& INT2(DateTime(3)), INT2(DateTime(5)), INT2(DateTime(6)),& INT2(DateTime(7)) ) rtn = NLSFormatDate(str, tm, NLS$LongDate) CALL MOVETO (INT2(10), INT2(80), pos) CALL OUTGTEXT('Long Format : ') CALL MOVETO (INT2(140), INT2(80), pos) CALL OUTGTEXT(str) rtn = NLSFormatDate(str, tm, NLS$UseAltCalendar) CALL MOVETO (INT2(10), INT2(100), pos) CALL OUTGTEXT('Short Format :') CALL MOVETO (INT2(140), INT2(100), pos) CALL OUTGTEXT(str) i4 = NLSGetLocaleInfo(NLS$LI_SDAYNAME1, str) CALL SetNameOfMonth(DateTime(2), Str) CALL MOVETO(INT2(40), INT2(ColY-60), pos) CALL OUTGTEXT('Calendar of') CALL MOVETO(INT2(160), INT2(ColY-60), pos) CALL OUTGTEXT(str) CALL Get1stDayWeek(day1st) !0:SUN, 1:MON,... CALL SetNameOfDay(day1st, Str) CALL MOVETO(INT2(40), INT2(ColY-40), pos) CALL OUTGTEXT('Starting on ') CALL MOVETO(INT2(160), INT2(ColY-40), pos) CALL OUTGTEXT(str) !Here we have ! day1st : indicates a day of week of 1st of this month ! 0:SUN, 1:MON, ..., 6:SAT ! ! Print header with names of days, different colors for weekends fontnum = SETFONT ('t''Arial''h14b') DO day=0,6 SELECT CASE (day) CASE (0) color = WeekendColor CASE (1) color = WeekdayColor CASE (2) color = WeekdayColor CASE (3) color = WeekdayColor CASE (4) color = WeekdayColor CASE (5) color = WeekdayColor CASE (6) color = WeekendColor CASE DEFAULT color = WeekendColor END SELECT i4 = setcolorrgb(color) CALL SetNameOfDayShort(day, str) CALL MOVETO(Calendar(day+1)%numx, Calendar(day+1)%numy-20,pos) CALL OUTGTEXT(str) END DO box = 0 ! Print initial blank boxes for days of first week that are not ! in the current month ! Do WHILE(box < day1st) CALL PrintBox(box, 0) box = box + 1 END DO fontnum = SETFONT ('t''Arial''h18b') ! Get number of days in month, adjusting for leap years if necessary ! DaysInMonth = EndOfMonth(DateTime(2)) IF (DateTime(2) == 2) THEN ! Check for leap year if February IF ((MOD(DateTime(1),4) == 0) .AND. & ((MOD(DateTime(1),100) /= 100) .OR. & (MOD(DateTime(1),400) == 0))) DaysInMonth = 29 END IF ! Print individual day boxes ! DO day=1, DaysInMonth CALL PrintBox(box, day) box = box + 1 END DO END subroutine !+++++++++++++++++++++++++++++++++++++++++++++++++ ! Return a day of week for specified day ! ! ! Parameter : 0:SUN, 1:MON, 2:Tue, ... ! subroutine Get1stDayWeek(day) USE DFWIN INTEGER(2) day type (T_SYSTEMTIME) systime CALL GETLOCALTIME(systime) !0:Sun, 1:Mon... day = mod(systime.wDayOfWeek+7 - mod(systime.wDay, 7) + 1, 7) END subroutine !+++++++++++++++++++++++++++++++++++++++++++++++++ subroutine SetNameOfDay(day, name) USE DFNLS INTEGER(2) day CHARACTER(*) name INTEGER(4) NameOfDay ! Get the long name of a day based on the locale setting ! Select Case (day) case (0) NameOfDay = NLS$LI_SDAYNAME7 !SUN case (1) NameOfDay = NLS$LI_SDAYNAME1 !MON case (2) NameOfDay = NLS$LI_SDAYNAME2 !TUE case (3) NameOfDay = NLS$LI_SDAYNAME3 !WED case (4) NameOfDay = NLS$LI_SDAYNAME4 !THU case (5) NameOfDay = NLS$LI_SDAYNAME5 !FRI case (6) NameOfDay = NLS$LI_SDAYNAME6 !SAT case DEFAULT NameOfDay = NLS$LI_SDAYNAME7 end select i4 = NLSGetLocaleInfo(NameOfDay, name) end subroutine !+++++++++++++++++++++++++++++++++++++++++++++++++ subroutine SetNameOfDayShort(day, name) USE DFNLS INTEGER(2) day CHARACTER(*) name INTEGER(4) NameOfDay ! Get the short name of a day based on the locale setting ! Select Case (day) case (0) NameOfDay = NLS$LI_SABBREVDAYNAME7 !SUN case (1) NameOfDay = NLS$LI_SABBREVDAYNAME1 !MON case (2) NameOfDay = NLS$LI_SABBREVDAYNAME2 !TUE case (3) NameOfDay = NLS$LI_SABBREVDAYNAME3 !WED case (4) NameOfDay = NLS$LI_SABBREVDAYNAME4 !THU case (5) NameOfDay = NLS$LI_SABBREVDAYNAME5 !FRI case (6) NameOfDay = NLS$LI_SABBREVDAYNAME6 !SAT case DEFAULT NameOfDay = NLS$LI_SABBREVDAYNAME7 end select i4 = NLSGetLocaleInfo(NameOfDay, name) end subroutine !+++++++++++++++++++++++++++++++++++++++++++++++++ subroutine SetNameOfMonth(month, name) USE DFNLS INTEGER(4) month, NameOfMonth CHARACTER*(*) name ! Get the name of the month based on the locale setting ! Select Case (month) case (1) NameOfMonth = NLS$LI_SMONTHNAME1 case (2) NameOfMonth = NLS$LI_SMONTHNAME2 case (3) NameOfMonth = NLS$LI_SMONTHNAME3 case (4) NameOfMonth = NLS$LI_SMONTHNAME4 case (5) NameOfMonth = NLS$LI_SMONTHNAME5 case (6) NameOfMonth = NLS$LI_SMONTHNAME6 case (7) NameOfMonth = NLS$LI_SMONTHNAME7 case (8) NameOfMonth = NLS$LI_SMONTHNAME8 case (9) NameOfMonth = NLS$LI_SMONTHNAME9 case (10) NameOfMonth = NLS$LI_SMONTHNAME10 case (11) NameOfMonth = NLS$LI_SMONTHNAME11 case (12) NameOfMonth = NLS$LI_SMONTHNAME12 case DEFAULT NameOfMonth = NLS$LI_SMONTHNAME1 end select i4 = NLSGetLocaleInfo(NameOfMonth, name) end subroutine