01-06-2025, 10:36 PM
Well here's a little Screen Zero Hero Productions goody from 25 years a ago.
I did a rewrite because my coding style back then was to use all caps, no remarks, non-descriptive variable names, and no indentation.
I uses the mapping technique, I described in the other thread, for mouse recognition.
Anyway, I have some bells and whistles I'd like to add going forward, but here is a working demo that shows how it can be applied in what I term as a flow-through routine. That means the calendar routine will keep flowing through the main routine, so what's going on there won't be disturbed.
I'll post back with some more info on keys and Mouse use. For now, just use arrow keys, page keys, Enter, Esc, F1, F12, or click / double click a day, x symbol, "<" or ">" symbols enclosing the month and year, or use the mouse wheel.
The goal here again is to turn the calendar popup into a library.
Pete
I did a rewrite because my coding style back then was to use all caps, no remarks, non-descriptive variable names, and no indentation.
I uses the mapping technique, I described in the other thread, for mouse recognition.
Anyway, I have some bells and whistles I'd like to add going forward, but here is a working demo that shows how it can be applied in what I term as a flow-through routine. That means the calendar routine will keep flowing through the main routine, so what's going on there won't be disturbed.
I'll post back with some more info on keys and Mouse use. For now, just use arrow keys, page keys, Enter, Esc, F1, F12, or click / double click a day, x symbol, "<" or ">" symbols enclosing the month and year, or use the mouse wheel.
Code: (Select All)
ReDim Shared mRow$(0) Palette 1, 8 Width 80, 28 _Font 16 Palette 7, 63 Color 0, 1 Cls View Print 3 To _Height - 2 Color 0, 7: Cls 2 View Print Color 14, 1 Locate 1, 1: Print String$(80, 196); Locate _Height - 1, 1: Print String$(80, 196); msg$ = "Chritmas Card and Calendar Demo" Locate 2, _Width \ 2 + 1 - Len(msg$) \ 2: Print msg$; Locate 3, 1: Print String$(80, 196); msg$ = "Press [F12] for Calendar or [F1] for Help." Locate _Height, _Width \ 2 + 1 - Len(msg$) \ 2: Print msg$; train$ = Space$(_Width) + "[oo]-[oo]-[Oo>" Color 2, 7 msg$ = " Merry Christmas " Locate 8, _Width \ 2 - Len(msg$) \ 2 + 1 Color 4, 7: Print msg$: Color 2 Locate 14 a$ = "*" For i = 1 To 13 If i > 10 Then a$ = "*": Color 0 Locate , _Width \ 2 - Len(a$) \ 2 + 1 Print a$ a$ = a$ + "**" Next y = CsrLin - 1 _Delay 2: x = 5: z = Timer Do If gocal = 0 Then Locate 14: a$ = "*" For i = 1 To 10 Locate , _Width \ 2 - Len(a$) \ 2 + 1 Color 2, 7: Print a$; For j = 1 To Len(a$) If Rnd * 20 > 17 Then Locate , _Width \ 2 - Len(a$) \ 2 + j Color 12 + 16: Print "*"; End If Next Print a$ = a$ + "**" Next End If If Abs(z - Timer) > x Then z = Timer If t = Len(train$) + 1 Then t = 1: x = 3 Else Sound 300, .05 t = t + 1: x = .05 Locate y, 1: Color 0, 7: Print Mid$(train$, Len(train$) - t, _Width); If t >= _Width / 2 + Len(_Trim$(train$)) Then Color 0: Locate , _Width \ 2 + 1: Print "*"; End If End If b$ = InKey$ If b$ = Chr$(0) + Chr$(134) Then _KeyClear gocal = 1: Color 0, 7: Locate y, 1: Print Space$(_Width); Color 0, 7: Locate , _Width \ 2 + 1: Print "*"; End If If b$ = Chr$(0) + Chr$(59) Then _MessageBox End If If gocal Then cal ds$ If Len(ds$) Then If ds$ <> "esc" Then _Title ds$ ds$ = "": gocal = 0: _KeyClear End If End If Loop Sub cal (Cal_DateSelected$) Static initiate ' Needed for this sub. Other static variables below are only required for flo-through. Static DaysInMonth$, EndDate, yr, mo, dy, month$, fullmonth$, oldmapy, oldday$, datex$, yy, xx Static BorderColorFg, BorderColorBg, ShadowFg, ShadowBg, DOWColor, DOWColorSunday, DOWHighlightBg Static w1, w2, w3, w4, xover, caly, calx, calfg, calbg, a1$, a2$, a3$, b1$, b2$, b3$ Static mx, my, lb, mb, mw, clkcnt, hlclose Locate , , 0 ' Hide cursor. If initiate = 0 Then initiate = 1 PCopy 0, 3 Palette 5, 63 BorderColorFg = 15 BorderColorBg = 1 ShadowFg = 8 ShadowBg = 0 DOWColor = 15 DOWColorSunday = 3 DOWHighlightBg = 4 j = 4 a1$ = Chr$(218) + String$(j, Chr$(196)) + Chr$(191) a2$ = Chr$(179) + String$(j, Chr$(32)) + Chr$(179) a3$ = Chr$(192) + String$(j, Chr$(196)) + Chr$(217) b1$ = a1$: b2$ = a2$: b3$ = a3$ For i = 1 To 7 - 1 a1$ = a1$ + " " + b1$ a2$ = a2$ + " " + b2$ a3$ = a3$ + " " + b3$ Next i w1 = 7 ' Top w2 = Int(_Width \ 2 - Len(a1$) \ 2) - 2 ' Left margin w3 = 18 ' Height w4 = Len(a1$) + 4 ' Width yy = w1: xx = Int(_Width \ 2 - Len(a1$) \ 2) ' Left top corner. Color BorderColorFg, BorderColorBg: Locate w1 - 1, w2: Print Chr$(218) + String$(w4 - 2, 196) + Chr$(191); ' Create box----------------------------------------------------------------------- Locate w1, w2 For i = 1 To w3 - 1 Color BorderColorFg, BorderColorBg: Locate , w2: Print Chr$(179);: Color 7, 1: Print Space$(w4 - 2);: Color BorderColorFg, 1: Print Chr$(179); Color 8, 0: Print Chr$(Screen(CsrLin, Pos(0)));: Print Chr$(Screen(CsrLin, Pos(0))) Next i Color BorderColorFg, BorderColorBg: Locate , w2: Print Chr$(192) + String$(w4 - 2, 196) + Chr$(217); Color ShadowFg, ShadowBg: Print Chr$(Screen(CsrLin, Pos(0)));: Print Chr$(Screen(CsrLin, Pos(0))) ' --------------------------------------------------------------------------------- Color ShadowFg, ShadowBg: Locate , w2 + 1 For i = 1 To w4 + 1 Print Chr$(Screen(CsrLin, Pos(0))); Next Locate yy + 1, xx Color 11, 1 Print " Sun. Mon. Tue. Wed. Thu. Fri. Sat. " DaysInMonth$ = "312831303130313130313031" GoSub update_calendar Else Locate caly, calx Color calfg, calbg End If Do _Limit 30 MyMouse_and_Keyboard lb, mb, rb, my, mx, mw, shift%, alt%, clkcnt, drag, b$, autokey$ If hlclose Then If Mid$(mRow$(my), mx, 1) <> "x" Then s1 = CsrLin: s2 = Pos(0) c1 = _DefaultColor: c2 = _BackgroundColor Color BorderColorBg, BorderColorFg Locate hlclose, InStr(mRow$(hlclose), "x") - 1 Color BorderColorBg, BorderColorBg: Print Chr$(221); Color BorderColorFg, BorderColorBg: Print "x"; Color BorderColorBg, BorderColorBg: Print Chr$(222); Color c1, c2 Locate s1, s2 hlclose = 0 End If Else If Mid$(mRow$(my), mx, 1) = "x" Then ' Highlight "x" close popup symbol. hlclose = my s1 = CsrLin: s2 = Pos(0) c1 = _DefaultColor: c2 = _BackgroundColor Color BorderColorFg, DOWHighlightBg Locate my, mx - 1 Color BorderColorBg, DOWHighlightBg: Print Chr$(221); Color BorderColorFg, DOWHighlightBg: Print "x"; Color BorderColorBg, DOWHighlightBg: Print Chr$(222); Color c1, c2 Locate s1, s2 End If End If If lb = 2 Then If hlclose Then b$ = Chr$(27) Else x$ = Mid$(mRow$(my), mx, 1) If x$ = "<" Or x$ = ">" Then If InStr(mx, mRow$(my), "ù") Then If x$ = "<" Then i = -1 Else i = 1 ' Change month. j = 0: GoSub change_mo_yr: If i = -999 Then Exit Do b$ = "lb" Else If x$ = "<" Then j = -1 Else j = 1 ' Change year. i = 0: GoSub change_mo_yr: If i = -999 Then Exit Do If dy > Val(Mid$(DaysInMonth$, mo * 2 - 1, 2)) Then dy = 0 ' Note: Automatically adjusts for a leap year when dy=0 is evaluated in next cycle. b$ = "lb" End If End If If InStr(mRow$(my), Chr$(179)) Then j = InStr(mx, mRow$(my), Chr$(179)) - 1 x$ = Mid$(mRow$(my), 1, j) x$ = Mid$(x$, _InStrRev(x$, Chr$(179)) + 1) If Val(x$) Then ' Click was on a calendar date. Select Case x$ ' Block is [3210] for j - mx. Case "2330": If j - mx > 1 Then x$ = "23" Else x$ = "30" Case "2431": If j - mx > 1 Then x$ = "24" Else x$ = "31" End Select dy = Val(x$) If clkcnt = 1 Then b$ = Chr$(13) ' A double click on a calendar date triggers selection. Else b$ = "lb" ' Highlights date clicked. End If End If End If End If Else If mw > 0 Then b$ = Chr$(0) + "P" ' Page up. If mw < 0 Then b$ = Chr$(0) + "H" ' Page dn. End If If Len(b$) Then h = 0: v = 0 Select Case b$ Case "lb" ' Mouse event. Case Chr$(9), Chr$(8) ' Tab or Backspace. datex$ = "" ' Triggers today's date. GoSub update_calendar Case Chr$(0) + "H", Chr$(0) + "M", Chr$(0) + "P", Chr$(0) + "K" ' Arrow keys. Select Case b$ Case Chr$(0) + "H": v = -1 Case Chr$(0) + "M": h = 1 Case Chr$(0) + "P": v = 1 Case Chr$(0) + "K": h = -1 End Select If h Then If dy + h > 0 And dy + h <= EndDate Then dy = dy + h day$ = LTrim$(Str$(dy)) If Len(day$) = 1 Then day$ = "0" + day$ Else If h > 0 Then i = 1: j = 0: GoSub change_mo_yr: If i = -999 Then Exit Do dy = 1 ElseIf h < 0 Then i = -1: j = 0: GoSub change_mo_yr: If i = -999 Then Exit Do dy = 0 End If End If ElseIf v Then If dy + v * 7 > 0 And dy + v * 7 <= EndDate Then dy = dy + v * 7 day$ = LTrim$(Str$(dy)) If Len(day$) = 1 Then day$ = "0" + day$ Else ' Change month/year. If v > 0 Then i = 1: j = 0: GoSub change_mo_yr: If i = -999 Then Exit Do dy = dy + 7 - EndDate ElseIf v < 0 Then i = -1: j = 0: GoSub change_mo_yr: If i = -999 Then Exit Do j = Val(Mid$(DaysInMonth$, mo * 2 - 1, 2)) If mo = 2 Then ' Leap Year adjustment. If yr Mod 4 = 0 And yr Mod 100 Or yr Mod 4 = 0 And yr Mod 100 = 0 And yr Mod 400 = 0 Then j = j + 1 End If dy = (dy - 7) + j End If End If End If Case Chr$(0) + "I", Chr$(0) + "Q" ' Page keys. If b$ = Chr$(0) + "I" Then i = -1 Else i = 1 j = 0: GoSub change_mo_yr: If i = -999 Then Exit Do j = (xover + dy - 1) \ 7 + 1 ' Calendar row. k = (xover + ((dy - 1) Mod 7)) Mod 7 + 1 ' Calendar column. cal_calc nul$, nul$, mo, yr, i, nul l = Val(Mid$(DaysInMonth$, mo * 2 - 1, 2)) dy = (j - 1) * 7 + k - i If dy > l Then dy = dy - 7 If dy < 1 Then dy = dy + 7 Case Chr$(0) + "G" ' Home key dy = 1 Case Chr$(0) + "O" ' End key. dy = EndDate Case Chr$(13) ' Enter key. temp$ = "Sunday Monday Tuesday Wednesday Thursday Friday Saturday" temp$ = Mid$(temp$, ((xover - 1 + dy) Mod 7) * 10 + 1, 10) Cal_DateSelected$ = _Trim$(temp$) + " " + fullmonth$ + " " + LTrim$(Str$(dy)) + ", " + LTrim$(Str$(yr)) PCopy 3, 0 initiate = 0 Exit Do Case Chr$(27), Chr$(0) + Chr$(134) ' Esc key or F12 toggle. PCopy 3, 0 Cal_DateSelected$ = "esc" initiate = 0 Exit Do Case Else Exit Do ' Bypass update_calendar routine, below. End Select If Len(b$) Then GoSub update_calendar End If End If Exit Do Loop caly = CsrLin: calx = Pos(0) calfg = _DefaultColor: calbg = _BackgroundColor Exit Sub change_mo_yr: k = mo + i ' Where k substitutes for month and l substitutes for year. l = yr + j If k = 0 Then l = l - 1: k = 12 If k = 13 Then i = i + 1: k = 1 If l <= 1582 Then Beep: dy = 1: i = -999 ' This value tell calling routine to exit the loop without changes. If l > 9999 Then Beep: dy = EndDate: i = -999 If i <> -999 Then mo = k: yr = l End If Return update_calendar: oldmapy = 0: oldmapx = 0: oldday$ = "" If datex$ = "" Then datex$ = Date$ mo = Val(Mid$(datex$, 1, 2)) yr = Val(Mid$(datex$, 7, 4)) dy = Val(Mid$(datex$, 4, 2)) End If cal_calc month$, fullmonth$, mo, yr, xover, leapyear Color BorderColorFg, 1 ' Make the squares to display the days. Locate yy + 2, xx For i = 1 To 5 a$ = a1$: cal_mapit a$ Locate CsrLin + 1, xx a$ = a2$: cal_mapit a$ Locate CsrLin + 1, xx a$ = a3$: cal_mapit a$ Locate CsrLin + 1, xx Next i Locate yy - 1, w2 + w4 - 4 ' Display date at top of the calendar. y_close = CsrLin: x_close = Pos(0) + 1 Color BorderColorBg, BorderColorBg: a$ = "Ý": cal_mapit a$ Color BorderColorFg, BorderColorBg: a$ = "x": cal_mapit a$ Color BorderColorBg, BorderColorBg: a$ = "Þ": cal_mapit a$ Color BorderColorFg, BorderColorBg Locate yy - 1, _Width / 2 - (Len(month$) + Len(LTrim$(Str$(yr)))) \ 2 - 3 a$ = "<": cal_mapit a$ a$ = month$: cal_mapit a$ a$ = ">": cal_mapit a$ a$ = "ù": cal_mapit a$ a$ = "<": cal_mapit a$ a$ = LTrim$(Str$(yr)): cal_mapit a$ a$ = ">": cal_mapit a$ EndDate = Val(Mid$(DaysInMonth$, mo * 2 - 1, 2)) k = EndDate If k = 28 And leapyear Then k = 29: EndDate = 29 If k = 30 And xover = 6 Then k = k - 1 ' Overlap 1 date. If k = 31 And xover > 4 Then k = k - (xover - 4) ' Overlap 2 dates. If dy = 0 Then dy = EndDate ' Zero signals backtracking in months or years. Places highlighted date as the last day of the month. j = yy + 3 Locate j, w2 - 1 + 7 * xover For i = 1 To k ' Display the days in the squares. Locate j, Pos(0) + 5 If (i + xover - 1) Mod 7 = 0 Then Color DOWColorSunday, BorderColorBg ' Sunday. If i > 1 Then j = j + 3: Locate j, xx + 2 ' Start next column. Else Color DOWColor, BorderColorBg ' Weekday/Saturday. End If If i < 10 Then a$ = "0" + LTrim$(Str$(i)) Else a$ = LTrim$(Str$(i)) If i = 23 Or i = 24 Then If mo <> 2 Then Select Case xover Case 5 If EndDate = 31 And i = 24 Then a$ = "2431" Case 6 Select Case EndDate Case 30 If i = 23 Then a$ = "2330" Case 31 If i = 23 Then a$ = "2330" If i = 24 Then a$ = "2431" End Select End Select End If End If If Len(a$) > 2 Then Locate , Pos(0) - 1 cal_mapit a$ If Len(a$) > 2 Then Locate , Pos(0) - 1 Next i day$ = LTrim$(Str$(dy)): If Len(day$) = 1 Then day$ = "0" + day$ GoSub highlight_date Return highlight_date: For i = 8 To _Height j = InStr(mRow$(i), day$) If j Then Color BorderColorFg, BorderColorBg If oldmapy Then Locate oldmapy, oldmapx: Print oldday$; k = 0 p = Val(day$) If p <> dy Then Beep If mo <> 2 And xover > 4 Then If dy = 23 Or dy = 24 Or dy = 30 Or dy = 31 Then Select Case xover Case 5 If EndDate = 31 Then If dy = 24 Or dy = 31 Then k = 1 Case 6 Select Case EndDate Case 30 If dy = 23 Or dy = 30 Then k = 1 Case 31 If dy = 23 Or dy = 24 Or dy = 30 Or dy = 31 Then k = 1 End Select End Select End If End If Color BorderColorBg, DOWHighlightBg If k Then Locate i, j: Print " "; Else Locate i, j - 1: Print Chr$(221) + " " + Chr$(222); End If If (Val(day$) + xover - 1) Mod 7 = 0 Then Color DOWColorSunday, DOWHighlightBg Else Color DOWColor, DOWHighlightBg End If Locate i, j: Print day$; mapy = i: mapx = j oldday$ = day$: oldmapy = mapy: oldmapx = mapx Exit For End If Next Return End Sub Sub cal_mapit (a$) Static initiate As Integer If initiate = 0 Then initiate = 1 ReDim mRow$(_Height) End If If mRow$(CsrLin) = "" Then mRow$(CsrLin) = Space$(_Width) Mid$(mRow$(CsrLin), Pos(0)) = a$ Print a$; End Sub Sub cal_calc (month$, fullmonth$, mo, yr, xover, leapyear) Select Case mo Case 1: month$ = "Jan": fullmonth$ = "January": ordinal = 0 Case 2: month$ = "Feb": fullmonth$ = "February": ordinal = 31 Case 3: month$ = "Mar": fullmonth$ = "March": ordinal = 59 Case 4: month$ = "Apr": fullmonth$ = "April": ordinal = 90 Case 5: month$ = "May": fullmonth$ = "May": ordinal = 120 Case 6: month$ = "Jun": fullmonth$ = "June": ordinal = 151 Case 7: month$ = "Jul": fullmonth$ = "July": ordinal = 181 Case 8: month$ = "Aug": fullmonth$ = "August": ordinal = 212 Case 9: month$ = "Sep": fullmonth$ = "September": ordinal = 243 Case 10: month$ = "Oct": fullmonth$ = "October": ordinal = 273 Case 11: month$ = "Nov": fullmonth$ = "November": ordinal = 304 Case 12: month$ = "Dec": fullmonth$ = "December": ordinal = 334 End Select leapyear = 0 xdays = (365 * yr) + yr \ 4 - yr \ 100 + yr \ 400 - 365 If yr Mod 4 = 0 And yr Mod 100 Or yr Mod 4 = 0 And yr Mod 100 = 0 And yr Mod 400 = 0 Then leapyear = 1 xdays = xdays + ordinal + 1 If leapyear And mo < 3 Then xdays = xdays - 1 xover = xdays Mod 7 ' First day of month and year. End Sub Sub MyMouse_and_Keyboard (lb, mb, rb, my, mx, mw, shift%, alt%, clkcnt, drag, b$, autokey$) Static oldmy, oldmx, z1, hover, mwy, oldmwy If Len(autokey$) Then b$ = Mid$(autokey$, 1, InStr(autokey$ + ",", ",") - 1) autokey$ = Mid$(autokey$, InStr(autokey$ + ",", ",") + 1) Exit Sub Else k& = _KeyHit If k& = 100307 Or k& = 100308 Then alt% = -1: Exit Sub Else If alt% Then alt% = 0 If k& > 0 Then b$ = MKI$(k&) If Right$(b$, 1) = Chr$(0) Then b$ = Left$(b$, 1) Else b$ = "" End If End If If z1 Then If Abs(Timer - z1) > .3 Then z1 = 0: clkcnt = 0 If lb > 0 Then If lb = 1 Then lb = -1 Else lb = 0 End If End If If rb > 0 Then If rb = 1 Then rb = -1 Else rb = 0 If mb > 0 Then If mb = 1 Then mb = -1 Else mb = 0 While _MouseInput mwy = mwy + _MouseWheel Wend my = _MouseY mx = _MouseX b_hover = 0 For i = 1 To nob ' number of buttons. If my >= y_btl(i) And my <= y_bbr(i) And mx >= x_btl(i) And mx <= x_bbr(i) Then b_hover = i Exit For End If Next If lb = -1 Then If oldmy And oldmx <> mx Or oldmy And oldmy <> my Then If mx <> oldmx Then drag = Sgn(mx - oldmx) ' Prevent zero which can occur if mouse moves off row when being dragged horizontally. End If End If If drag = 0 Then If mwy <> oldmw Then mw = Sgn(mwy - oldmwy): mwy = 0 Else mw = 0 End If oldmwy = mwy If _KeyDown(100303) Or _KeyDown(100304) Then shift% = -1 Else If shift% Then shift% = 0 End If If lb = -1 And _MouseButton(1) = 0 Then lb = 2: drag = 0: hover = 0 ElseIf rb = -1 And _MouseButton(2) = 0 Then rb = 2 ElseIf mb = -1 And _MouseButton(3) = 0 Then mb = 2 End If If _MouseButton(1) Then If lb = 0 Then lb = 1 If z1 = 0 Then z1 = Timer ' Let first click go through. Else clkcnt = clkcnt + 1 End If End If ElseIf _MouseButton(2) And rb = 0 Then rb = 1 ElseIf _MouseButton(3) And mb = 0 Then mb = 1 End If oldmy = my: oldmx = mx End Sub
The goal here again is to turn the calendar popup into a library.
Pete
