home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / vb_code1 / dt01 / dt01.frm < prev    next >
Text File  |  1993-12-02  |  16KB  |  463 lines
  1. VERSION 2.00
  2. Begin Form frmCalendar 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H00C0C0C0&
  5.    BorderStyle     =   0  'None
  6.    ClientHeight    =   1020
  7.    ClientLeft      =   1332
  8.    ClientTop       =   1704
  9.    ClientWidth     =   1956
  10.    ForeColor       =   &H00000000&
  11.    Height          =   1440
  12.    Left            =   1284
  13.    ScaleHeight     =   1020
  14.    ScaleWidth      =   1956
  15.    Top             =   1332
  16.    Width           =   2052
  17.    Begin SSRibbon gpMonthSpin 
  18.       BackColor       =   &H00C0C0C0&
  19.       BevelWidth      =   0
  20.       Height          =   252
  21.       Index           =   2
  22.       Left            =   1320
  23.       Outline         =   0   'False
  24.       PictureDnChange =   2  'Invert 'PictureUp' Bitmap
  25.       PictureUp       =   DT01.FRX:0000
  26.       Top             =   120
  27.       Width           =   300
  28.    End
  29.    Begin SSRibbon gpMonthSpin 
  30.       BackColor       =   &H00C0C0C0&
  31.       BevelWidth      =   0
  32.       Height          =   252
  33.       Index           =   1
  34.       Left            =   360
  35.       Outline         =   0   'False
  36.       PictureDnChange =   0  'Use 'PictureUp' Bitmap Unchanged
  37.       PictureUp       =   DT01.FRX:0686
  38.       RoundedCorners  =   0   'False
  39.       Top             =   120
  40.       Width           =   300
  41.    End
  42.    Begin PictureBox pic 
  43.       AutoRedraw      =   -1  'True
  44.       BackColor       =   &H00C0C0C0&
  45.       BorderStyle     =   0  'None
  46.       FontTransparent =   0   'False
  47.       ForeColor       =   &H00000000&
  48.       Height          =   372
  49.       Left            =   480
  50.       ScaleHeight     =   372
  51.       ScaleWidth      =   372
  52.       TabIndex        =   0
  53.       Top             =   480
  54.       Width           =   372
  55.    End
  56.    Begin Timer TmrMonthSpin 
  57.       Enabled         =   0   'False
  58.       Interval        =   200
  59.       Left            =   1320
  60.       Top             =   480
  61.    End
  62.    Begin Label lblMonthText 
  63.       Alignment       =   2  'Center
  64.       BackColor       =   &H00C0C0C0&
  65.       Caption         =   "lMonth"
  66.       Height          =   192
  67.       Left            =   720
  68.       TabIndex        =   1
  69.       Top             =   120
  70.       Width           =   564
  71.    End
  72. End
  73. Option Explicit
  74.  
  75.  
  76.     ' Create form level globals?
  77.     Dim nCurrentYear As Integer
  78.     Dim nCurrentMonth As Integer
  79.     Dim nCurrentDay As Integer
  80.     Dim nStartDay As Integer
  81.     Dim nTotalDays As Integer
  82.     Dim nBlockNdx As Integer
  83.     Dim nCopyBlockNdx As Integer
  84.     Dim nBlockHeight As Integer
  85.     Dim nWidth As Integer
  86.     Dim nHeight As Integer
  87.  
  88. Sub Form_Activate ()
  89.  
  90.     ' Initialize form level date variables.
  91.     ' -------------------------------------
  92.     If IsDate(gDate) Then
  93.         nCurrentYear = Year(gDate)
  94.         nCurrentMonth = Month(gDate)
  95.         nCurrentDay = Day(gDate)
  96.     Else
  97.         nCurrentYear = Year(Now)
  98.         nCurrentMonth = Month(Now)
  99.         nCurrentDay = Day(Now)
  100.     End If
  101.  
  102.  
  103.     ' print days of the month.
  104.     ' ------------------------
  105.     PrintMonth
  106.  
  107. End Sub
  108.  
  109. '================================================
  110. ' = Get all the static non-moving bits out here =
  111. '================================================
  112. Sub Form_Load ()
  113.     
  114.     Dim i As Integer
  115.     Dim nOldWidth As Integer
  116.  
  117.     ' Set width/height of one char.
  118.     ' -----------------------------
  119.     nWidth = TextWidth("M") ' Change this for bigger/smaller calendars.
  120.     nHeight = nWidth * 1.9
  121.     
  122.  
  123.     ' resize the form.
  124.     ' ----------------
  125.     Me.Height = (nHeight * 6) + (nHeight * .75)
  126.     Me.Width = ((nWidth * 2) * 7) + (nWidth * 1.25)
  127.  
  128.     ' position left/right arrows.
  129.     ' ---------------------------
  130.     gpMonthSpin(1).Top = nHeight / 4
  131.     gpMonthSpin(2).Top = nHeight / 4
  132.     gpMonthSpin(1).Left = nWidth / 2
  133.     gpMonthSpin(2).Left = Width - gpMonthSpin(1).Width - (nWidth / 2)
  134.  
  135.     ' position month label between l/r arrows.
  136.     ' ----------------------------------------
  137.     lblMonthText.Top = nHeight / 4
  138.     lblMonthText.Left = gpMonthSpin(1).Left + gpMonthSpin(1).Width
  139.     lblMonthText.Width = gpMonthSpin(2).Left - lblMonthText.Left
  140.  
  141.     ' size background panel.
  142.     ' ----------------------
  143.     pic.Top = (nHeight * 2.25)
  144.     pic.Left = (nWidth / 2)
  145.     pic.Width = ((nWidth * 2) * 7) + 20
  146.     pic.Height = (nHeight * 4) + 50
  147.     
  148.     ' Output Day text.
  149.     ' ----------------
  150.     For i = 1 To 7
  151.         CurrentY = nHeight * 1.25
  152.         CurrentX = (i * (nWidth * 2)) - (nWidth * 1.5)
  153.         Print Mid$("SuMoTuWeThFrSa", i * 2 - 1, 2)
  154.     Next
  155.  
  156.     ' draw separator line + shadow.
  157.     ' -----------------------------
  158.     Line (0, nHeight * 2)-(Width, nHeight * 2), QBColor(0)
  159.     Line (0, nHeight * 2 + (nHeight / 29))-(Width, nHeight * 2 + (nHeight / 29)), QBColor(15)
  160.  
  161.     ' Attempt at a 3D border.
  162.     ' -----------------------
  163.     nOldWidth = Me.DrawWidth
  164.     Me.DrawWidth = 10
  165.     Me.Line (-30, -30)-Step(Me.Width + 50, 0), QBColor(15)
  166.     Me.Line -Step(0, Me.Height + 40), QBColor(8)
  167.     Me.Line -Step(-(Me.Width + 50), 0), QBColor(8)
  168.     Me.Line -Step(0, -(Me.Height + 40)), QBColor(15)
  169.     Me.DrawWidth = nOldWidth
  170.  
  171. End Sub
  172.  
  173. ' =============================================================
  174. ' Name.........: GetNumDaysInMonth(nYear, nMonth)
  175. ' Description..: Computes the number of days in any given month
  176. ' Parameters...: <nYear>  - needed to check for leap years
  177. '                <nMonth> - the month number (1-12)
  178. ' Returns......: An integer representing the days in the month
  179. ' =============================================================
  180. Function GetNumDaysInMonth (nYear As Integer, nMonth As Integer) As Integer
  181.    
  182.     Dim cMonth As String, nDays As Integer
  183.  
  184.     cMonth = "312831303130313130313031"
  185.  
  186.     ' Set defaults.
  187.     ' -------------
  188.     If nYear < 100 Or nYear > 9999 Then nYear = Year(Now)
  189.     If nMonth < 1 Or nMonth > 12 Then nMonth = Month(Now)
  190.  
  191.     ' Set the number of days in the requested month.
  192.     ' ----------------------------------------------
  193.     nDays = Val(Mid$(cMonth, nMonth * 2 - 2 + 1, 2))
  194.  
  195.     ' Compensate if requested year is a leap year, and month is February.
  196.     ' -------------------------------------------------------------------
  197.     If IsLeapYear(nYear) And nMonth = 2 Then nDays = nDays + 1
  198.    
  199.     GetNumDaysInMonth = nDays
  200.  
  201. End Function
  202.  
  203. Sub gpMonthSpin_MouseDown (Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
  204.  
  205.     gpMonthSpin(Index).PictureDnChange = 2
  206.     
  207.     TmrMonthSpin.Interval = 500
  208.     TmrMonthSpin.Enabled = True
  209.     TmrMonthSpin.Tag = Choose(Index, -1, 1)
  210.     nCurrentMonth = nCurrentMonth + TmrMonthSpin.Tag
  211.     PrintMonthText
  212.  
  213. End Sub
  214.  
  215. Sub gpMonthSpin_MouseUp (Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
  216.  
  217.     gpMonthSpin(Index).PictureDnChange = 0
  218.  
  219.     ' turn off timer
  220.     TmrMonthSpin.Enabled = False
  221.     PrintMonth
  222.  
  223. End Sub
  224.  
  225. ' =============================================================
  226. ' Name.........: IsLeapYear( nYear )
  227. ' Description..:  Determines if a year is a leap year, or not.
  228. ' Parameters...: <nYear>  -
  229. ' Returns......: An integer (boolean). True = it is a leap year
  230. ' =============================================================
  231. Function IsLeapYear (nYear)
  232.    
  233.    ' If the year is evenly divisible by 4 and not divisible
  234.    ' by 100, or if the year is evenly divisible by 400, then
  235.    ' it's a leap year.
  236.  
  237.    IsLeapYear = (nYear Mod 4 = 0 And nYear Mod 100 <> 0) Or (nYear Mod 400 = 0)
  238.  
  239. End Function
  240.  
  241. Sub pic_Click ()
  242.  
  243.     ' Return to 'sub-level' code.
  244.     ' ---------------------------
  245.     If nCurrentDay > 0 Then
  246.         gDate = DateSerial(nCurrentYear, nCurrentMonth, nCurrentDay)
  247.         Me.Hide
  248.     End If
  249.  
  250. End Sub
  251.  
  252. Sub pic_MouseDown (Button As Integer, Shift As Integer, x As Single, y As Single)
  253.  
  254.     ' Just pass it along to "MouseMove".
  255.     ' ----------------------------------
  256.     pic_MouseMove Button, Shift, x, y
  257.  
  258. End Sub
  259.  
  260. Sub pic_MouseMove (Button As Integer, Shift As Integer, x As Single, y As Single)
  261.     
  262.     Dim i  As Integer
  263.     Dim xt As Integer, x1 As Integer, x2 As Integer
  264.     Dim yt As Integer, y1 As Integer, y2 As Integer
  265.  
  266.     ' OK. The mouse is moving over the picture. Do we care?
  267.     ' Only if the left mouse button is pressed.
  268.     ' We then need to find out which part of the picture,
  269.     ' the mouse is over, and change the shadow state.
  270.     
  271.     If (Button = 1) Then
  272.  
  273.         For i = 1 To 42
  274.             
  275.             yt = Int((i - 1) / 7) + 1
  276.             xt = i - (Int((yt - 1) * 7))
  277.             y1 = (yt - 1) * nBlockHeight: y2 = yt * nBlockHeight
  278.             x1 = (xt - 1) * (nWidth * 2): x2 = xt * (nWidth * 2)
  279.     
  280.             If (x >= x1) And (x <= x2) And (y >= y1) And (y <= y2) Then nBlockNdx = i: Exit For
  281.  
  282.         Next
  283.  
  284.         If (nBlockNdx <> nCopyBlockNdx) And (nBlockNdx > 0) And (nBlockNdx - nStartDay <= nTotalDays) And (nBlockNdx - nStartDay > 0) Then
  285.             
  286.             PrintDay nCopyBlockNdx, 0, 0, 0
  287.             nCopyBlockNdx = nBlockNdx
  288.             nCurrentDay = nBlockNdx - nStartDay
  289.             PrintDay nCopyBlockNdx, 1, 0, 0
  290.             
  291.         End If
  292.     
  293.     End If
  294.  
  295. End Sub
  296.  
  297. Sub pic_MouseUp (Button As Integer, Shift As Integer, x As Single, y As Single)
  298.  
  299.     pic_Click
  300.  
  301. End Sub
  302.  
  303. ' ===============================================================
  304. ' Name.........: PrintDay( nDayIndex, lBorder, lBold, nCaption )
  305. ' Description..: Draws / Clears the border around a box
  306. ' Parameters...: <nDayIndex>  - Number of box to deal with (1-42)
  307. '                <lSetBorder> - True  = draw a 3D border
  308. '                               false = clear the border
  309. ' ===============================================================
  310. Sub PrintDay (nCurrBlock, lBorder As Integer, lBold As Integer, nCaption As Integer)
  311.     
  312.     Dim x As Integer, x1 As Integer, x2 As Integer
  313.     Dim y As Integer, y1 As Integer, y2 As Integer
  314.     Dim cCaption As String
  315.     ReDim aBorderColours(4)
  316.         
  317.     ' Setup colours for border / no border.
  318.     ' -------------------------------------
  319.     If lBorder Then
  320.         aBorderColours(1) = 0
  321.         aBorderColours(2) = 15
  322.         aBorderColours(3) = 15
  323.         aBorderColours(4) = 0
  324.     Else
  325.         aBorderColours(1) = 7
  326.         aBorderColours(2) = 7
  327.         aBorderColours(3) = 7
  328.         aBorderColours(4) = 7
  329.     End If
  330.  
  331.     y = Int((nCurrBlock - 1) / 7) + 1
  332.     x = nCurrBlock - (Int((y - 1) * 7))
  333.     y1 = (y - 1) * nBlockHeight: y2 = y * nBlockHeight
  334.     x1 = (x - 1) * (nWidth * 2): x2 = x * (nWidth * 2)
  335.         
  336.     pic.Line (x1, y1)-(x2, y1), QBColor(aBorderColours(1))
  337.     pic.Line (x2, y1)-(x2, y2), QBColor(aBorderColours(2))
  338.     pic.Line (x2, y2)-(x1, y2), QBColor(aBorderColours(3))
  339.     pic.Line (x1, y2)-(x1, y1), QBColor(aBorderColours(4))
  340.  
  341.  
  342.     ' Set Bold/Unbold attribute (only Bold if it's today)
  343.     ' and print caption (only if there is a caption to print!)
  344.     If nCaption > 0 Then
  345.             
  346.         pic.FontBold = False: pic.ForeColor = QBColor(0)
  347.         If lBold Then pic.FontBold = True: : pic.ForeColor = QBColor(4)
  348.     
  349.         cCaption = CStr(nCaption)
  350.         pic.CurrentX = x1 + ((x2 - x1) - TextWidth(cCaption)) / 2
  351.         pic.CurrentY = y1 + ((y2 - y1) - TextHeight(cCaption)) / 2
  352.         pic.Print cCaption
  353.  
  354.     End If
  355.  
  356. End Sub
  357.  
  358. ' =============================================================
  359. ' Name.........: PrintMonth()
  360. ' Description..: Output month text & numbers
  361. ' Notes........: This is a 'mega-slow' procedure. It's a pity
  362. '                we can't do without it.
  363. ' =============================================================
  364. Sub PrintMonth ()
  365.  
  366.     Static nCopyYear As Integer  ' Saved, so we don't needlessly print the same
  367.     Static nCopyMonth As Integer ' month twice.
  368.  
  369.     Dim nCount  As Integer
  370.     Dim nWeeks As Integer
  371.     Dim nCaption As Integer
  372.     
  373.     If (nCurrentYear <> nCopyYear Or nCurrentMonth <> nCopyMonth) Then
  374.         pic.Visible = False
  375.         pic.Cls
  376.         nCopyYear = nCurrentYear: nCopyMonth = nCurrentMonth
  377.         
  378.         ' ======================================================
  379.         ' First day in a month.
  380.         ' An integer between 1 (Sunday) and 7 (Saturday)
  381.         ' that represents the day of the week for a date argument.
  382.         ' ======================================================
  383.         nStartDay = Weekday(DateSerial(nCurrentYear, nCurrentMonth, 1)) - 1
  384.         
  385.         ' ======================================================
  386.         ' Total days in a month.
  387.         ' An integer between 1 and ( 28 or 29 or 30 or 31 )
  388.         ' that represents the number of days in a month.
  389.         ' ======================================================
  390.         nTotalDays = GetNumDaysInMonth(nCurrentYear, nCurrentMonth)
  391.  
  392.         ' ======================================================
  393.         ' Total weeks in a month.
  394.         ' An integer between 4 and 6
  395.         ' that represents the number of weeks in a month.
  396.         ' ======================================================
  397.         nWeeks = Int((nTotalDays + nStartDay) / 7) + Sgn((nTotalDays + nStartDay) Mod 7)
  398.         
  399.         ' ======================================================
  400.         ' Calculate vertical space needed to display the days
  401.         ' ======================================================
  402.         nBlockHeight = (pic.Height - 50) / nWeeks
  403.  
  404.         PrintMonthText
  405.         ' ======================================================
  406.         ' Adjust 'Current Day' In case it's .GT. 'total days'
  407.         ' ======================================================
  408.         While nCurrentDay > nTotalDays: nCurrentDay = nCurrentDay - 1: Wend
  409.         nBlockNdx = nCurrentDay + nStartDay
  410.         nCopyBlockNdx = nBlockNdx
  411.  
  412.         ' ==============================================
  413.         '  Output the month 'Captions'
  414.         ' ==============================================
  415.         For nCount = 1 To nWeeks * 7
  416.             
  417.             nCaption = IIf((nCount >= nStartDay + 1) And (nCount < nTotalDays + nStartDay + 1), nCount - nStartDay, 0)
  418.             
  419.             PrintDay nCount, 0, nCurrentYear = Year(Now) And nCurrentMonth = Month(Now) And nCount - nStartDay = Day(Now), nCaption
  420.  
  421.         Next
  422.  
  423.         ' ==============================================
  424.         ' Draw the border around selected day.
  425.         ' ==============================================
  426.         PrintDay nCurrentDay + nStartDay, 1, 0, 0
  427.  
  428.         pic.Visible = True
  429.  
  430.     End If
  431.  
  432. End Sub
  433.  
  434. ' =============================================================
  435. ' Name.........: PrintMonthText()
  436. ' Description..: Output month text
  437. ' =============================================================
  438. Sub PrintMonthText ()
  439.  
  440.     If nCurrentMonth > 12 Then nCurrentMonth = 1: nCurrentYear = nCurrentYear + 1
  441.     If nCurrentMonth < 1 Then nCurrentMonth = 12: nCurrentYear = nCurrentYear - 1
  442.     nCurrentYear = IIf(nCurrentYear > 9999, 9999, nCurrentYear)
  443.     nCurrentYear = IIf(nCurrentYear < 100, 100, nCurrentYear)
  444.  
  445.     lblMonthText.Caption = Format$(DateSerial(nCurrentYear, nCurrentMonth, 1), "mmmm yyyy")
  446.     Me.Refresh
  447.     
  448. End Sub
  449.  
  450. Sub TmrMonthSpin_Timer ()
  451.     
  452.     ' Speed up the timer, on each call.
  453.     ' ---------------------------------
  454.     TmrMonthSpin.Interval = TmrMonthSpin.Interval * .8
  455.     
  456.     ' Update the current month, and print text.
  457.     ' ----------------------------------------
  458.     nCurrentMonth = nCurrentMonth + TmrMonthSpin.Tag
  459.     PrintMonthText
  460.  
  461. End Sub
  462.  
  463.