Yesterday, 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 SubThe goal here again is to turn the calendar popup into a library.
Pete
