home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Calendar_o2043231182007.psc / Calendar.frm < prev    next >
Text File  |  2006-11-07  |  10KB  |  305 lines
  1. VERSION 5.00
  2. Begin VB.Form frmCalendar 
  3.    BorderStyle     =   4  '│µ╜u⌐T⌐wñu¿π╡°╡í
  4.    Caption         =   "Get Date"
  5.    ClientHeight    =   2415
  6.    ClientLeft      =   3285
  7.    ClientTop       =   3825
  8.    ClientWidth     =   3255
  9.    Icon            =   "Calendar.frx":0000
  10.    KeyPreview      =   -1  'True
  11.    LinkTopic       =   "Form3"
  12.    MaxButton       =   0   'False
  13.    MinButton       =   0   'False
  14.    PaletteMode     =   1  '│╠ñW╝h▒▒¿ε╢╡¬║╜╒ªΓ╜L
  15.    ScaleHeight     =   2415
  16.    ScaleWidth      =   3255
  17.    ShowInTaskbar   =   0   'False
  18.    StartUpPosition =   2  '┐├╣⌡ññÑí
  19.    Begin VB.PictureBox picMonth 
  20.       BorderStyle     =   0  '¿Sª│«╪╜u
  21.       ClipControls    =   0   'False
  22.       Height          =   1815
  23.       Left            =   120
  24.       ScaleHeight     =   1815
  25.       ScaleWidth      =   3015
  26.       TabIndex        =   0
  27.       Top             =   480
  28.       Width           =   3015
  29.    End
  30.    Begin VB.Label lblMonth 
  31.       Alignment       =   2  '╕mññ╣∩╗⌠
  32.       BeginProperty Font 
  33.          Name            =   "MS Sans Serif"
  34.          Size            =   8.25
  35.          Charset         =   0
  36.          Weight          =   700
  37.          Underline       =   0   'False
  38.          Italic          =   0   'False
  39.          Strikethrough   =   0   'False
  40.       EndProperty
  41.       Height          =   255
  42.       Left            =   360
  43.       TabIndex        =   1
  44.       Top             =   120
  45.       Width           =   2535
  46.    End
  47.    Begin VB.Label lblNext 
  48.       Alignment       =   2  '╕mññ╣∩╗⌠
  49.       Caption         =   ">>"
  50.       BeginProperty Font 
  51.          Name            =   "MS Sans Serif"
  52.          Size            =   8.25
  53.          Charset         =   0
  54.          Weight          =   700
  55.          Underline       =   0   'False
  56.          Italic          =   0   'False
  57.          Strikethrough   =   0   'False
  58.       EndProperty
  59.       Height          =   255
  60.       Left            =   2880
  61.       TabIndex        =   3
  62.       Top             =   120
  63.       Width           =   375
  64.    End
  65.    Begin VB.Label lblPrev 
  66.       Alignment       =   2  '╕mññ╣∩╗⌠
  67.       Caption         =   "<<"
  68.       BeginProperty Font 
  69.          Name            =   "MS Sans Serif"
  70.          Size            =   8.25
  71.          Charset         =   0
  72.          Weight          =   700
  73.          Underline       =   0   'False
  74.          Italic          =   0   'False
  75.          Strikethrough   =   0   'False
  76.       EndProperty
  77.       Height          =   255
  78.       Left            =   0
  79.       TabIndex        =   2
  80.       Top             =   120
  81.       Width           =   375
  82.    End
  83. End
  84. Attribute VB_Name = "frmCalendar"
  85. Attribute VB_GlobalNameSpace = False
  86. Attribute VB_Creatable = False
  87. Attribute VB_PredeclaredId = True
  88. Attribute VB_Exposed = False
  89. 'Calendar - Calendar demo program
  90. 'Copyright (c) 1997 SoftCircuits Programming (R)
  91. 'Redistributed by Permission.
  92. '
  93. 'This example program demonstrates how to create a mini calendar in
  94. 'Visual Basic 5.0. It takes advantage of the changes made to VB in
  95. 'version 4 that allow forms to have public methods and properties.
  96. 'Although the Calendar form contains a fair amount of code, you can
  97. 'take advantage of all of its features by calling the single method,
  98. 'GetDate().
  99. '
  100. 'This program may be distributed on the condition that it is
  101. 'distributed in full and unchanged, and that no fee is charged for
  102. 'such distribution with the exception of reasonable shipping and media
  103. 'charged. In addition, the code in this program may be incorporated
  104. 'into your own programs and the resulting programs may be distributed
  105. 'without payment of royalties.
  106. '
  107. 'This example program was provided by:
  108. ' SoftCircuits Programming
  109. ' http://www.softcircuits.com
  110. ' P.O. Box 16262
  111. ' Irvine, CA 92623
  112. Option Explicit
  113.  
  114. 'Grid dimensions for days
  115. Private Const GRID_ROWS = 6
  116. Private Const GRID_COLS = 7
  117.  
  118. 'Private variables
  119. Private m_CurrDate As Date, m_bAcceptChange As Boolean
  120. Private m_nGridWidth As Integer, m_nGridHeight As Integer
  121.  
  122. 'Public function: If user selects date, sets UserDate to selected
  123. 'date and returns True. Otherwise, returns False.
  124. Public Function GetDate(UserDate As Date, Optional Title) As Boolean
  125.     'Store user-specified date
  126.     m_CurrDate = UserDate
  127.     'Use caller-specified caption if any
  128.     If Not IsMissing(Title) Then
  129.         Caption = Title
  130.     End If
  131.     'Display this form
  132.     Me.Show vbModal
  133.     'Return selected date
  134.     If m_bAcceptChange Then
  135.         UserDate = m_CurrDate
  136.     End If
  137.     'Return value indicates if date was selected
  138.     GetDate = m_bAcceptChange
  139. End Function
  140.  
  141. 'Form initialization
  142. Private Sub Form_Load()
  143.     'Calculate calendar grid measurements
  144.     m_nGridWidth = ((picMonth.ScaleWidth - Screen.TwipsPerPixelX) \ GRID_COLS)
  145.     m_nGridHeight = ((picMonth.ScaleHeight - Screen.TwipsPerPixelY) \ GRID_ROWS)
  146.     m_bAcceptChange = False
  147. End Sub
  148.  
  149. 'Process user keystrokes
  150. Private Sub picMonth_KeyDown(KeyCode As Integer, Shift As Integer)
  151.     Dim NewDate As Date
  152.     
  153.     Select Case KeyCode
  154.         Case vbKeyRight
  155.             NewDate = DateAdd("d", 1, m_CurrDate)
  156.         Case vbKeyLeft
  157.             NewDate = DateAdd("d", -1, m_CurrDate)
  158.         Case vbKeyDown
  159.             NewDate = DateAdd("ww", 1, m_CurrDate)
  160.         Case vbKeyUp
  161.             NewDate = DateAdd("ww", -1, m_CurrDate)
  162.         Case vbKeyPageDown
  163.             NewDate = DateAdd("m", 1, m_CurrDate)
  164.         Case vbKeyPageUp
  165.             NewDate = DateAdd("m", -1, m_CurrDate)
  166.         Case vbKeyReturn
  167.             m_bAcceptChange = True
  168.             Unload Me
  169.             Exit Sub
  170.         Case vbKeyEscape
  171.             Unload Me
  172.             Exit Sub
  173.         Case Else
  174.             Exit Sub
  175.     End Select
  176.     SetNewDate NewDate
  177.     KeyCode = 0
  178. End Sub
  179.  
  180. 'Double-click accepts current date
  181. Private Sub picMonth_DblClick()
  182.     m_bAcceptChange = True
  183.     Unload Me
  184. End Sub
  185.  
  186. ' Select the date by mouse
  187. Private Sub picMonth_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  188.     Dim i As Integer, MaxDay As Integer
  189.  
  190.     'Determine which date is being clicked
  191.     i = Weekday(DateSerial(Year(m_CurrDate), Month(m_CurrDate), 1)) - 1
  192.     i = (((X \ m_nGridWidth) + 1) + ((Y \ m_nGridHeight) * GRID_COLS)) - i
  193.     'Get last day of current month
  194.     MaxDay = Day(DateAdd("d", -1, DateSerial(Year(m_CurrDate), Month(m_CurrDate) + 1, 1)))
  195.     If i >= 1 And i <= MaxDay Then
  196.         SetNewDate DateSerial(Year(m_CurrDate), Month(m_CurrDate), i)
  197.     End If
  198. End Sub
  199.  
  200. 'Click on ">>" goes to next month
  201. Private Sub lblNext_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  202.     If Button And vbLeftButton Then
  203.         SetNewDate DateAdd("m", 1, m_CurrDate)
  204.     End If
  205. End Sub
  206.  
  207. 'Double-click has same effect
  208. Private Sub lblNext_DblClick()
  209.     SetNewDate DateAdd("m", 1, m_CurrDate)
  210. End Sub
  211.  
  212. 'Click on "<<" goes to previous month
  213. Private Sub lblPrev_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  214.     If Button And vbLeftButton Then
  215.         SetNewDate DateAdd("m", -1, m_CurrDate)
  216.     End If
  217. End Sub
  218.  
  219. 'Double-click has same effect
  220. Private Sub lblPrev_DblClick()
  221.     SetNewDate DateAdd("m", -1, m_CurrDate)
  222. End Sub
  223.  
  224. 'Changes the selected date
  225. Private Sub SetNewDate(NewDate As Date)
  226.     If Month(m_CurrDate) = Month(NewDate) And Year(m_CurrDate) = Year(NewDate) Then
  227.         DrawSelectionBox False
  228.         m_CurrDate = NewDate
  229.         DrawSelectionBox True
  230.     Else
  231.         m_CurrDate = NewDate
  232.         picMonth_Paint
  233.     End If
  234. End Sub
  235.  
  236. 'Here's the calendar paint handler; displayes the calendar days
  237. Private Sub picMonth_Paint()
  238.     Dim i As Integer, j As Integer, X As Integer, Y As Integer
  239.     Dim NumDays As Integer, CurrPos As Integer, bCurrMonth As Boolean
  240.     Dim MonthStart As Date, buffer As String
  241.     
  242.     'Determine if this month is today's month
  243.     If Month(m_CurrDate) = Month(Date) And Year(m_CurrDate) = Year(Date) Then
  244.         bCurrMonth = True
  245.     End If
  246.     'Get first date in the month
  247.     MonthStart = DateSerial(Year(m_CurrDate), Month(m_CurrDate), 1)
  248.     'Number of days in the month
  249.     NumDays = DateDiff("d", MonthStart, DateAdd("m", 1, MonthStart))
  250.     'Get first weekday in the month (0 - based)
  251.     j = Weekday(MonthStart) - 1
  252.     'Tweak for 1-based For/Next index
  253.     j = j - 1
  254.     'Show current month/year
  255.     lblMonth = Format$(m_CurrDate, "mmmm yyyy")
  256.     'Clear existing data
  257.     picMonth.Cls
  258.     'Display dates for current month
  259.     For i = 1 To NumDays
  260.         CurrPos = i + j
  261.         X = (CurrPos Mod GRID_COLS) * m_nGridWidth
  262.         Y = (CurrPos \ GRID_COLS) * m_nGridHeight
  263.         'Show date as bold if today's date
  264.         If bCurrMonth And i = Day(Date) Then
  265.             picMonth.Font.Bold = True
  266.         Else
  267.             picMonth.Font.Bold = False
  268.         End If
  269.         'Center date within "date cell"
  270.         buffer = CStr(i)
  271.         picMonth.CurrentX = X + ((m_nGridWidth - picMonth.TextWidth(buffer)) / 2)
  272.         picMonth.CurrentY = Y + ((m_nGridHeight - picMonth.TextHeight(buffer)) / 2)
  273.         'Print date
  274.         picMonth.Print buffer;
  275.     Next i
  276.     'Indicate selected date
  277.     DrawSelectionBox True
  278. End Sub
  279.  
  280. 'Draw or clears the selection box around the current date
  281. Private Sub DrawSelectionBox(bSelected As Boolean)
  282.     Dim clrTopLeft As Long, clrBottomRight As Long
  283.     Dim i As Integer, X As Integer, Y As Integer
  284.  
  285.     'Set highlight and shadow colors
  286.     If bSelected Then
  287.         clrTopLeft = vbButtonShadow
  288.         clrBottomRight = vb3DHighlight
  289.     Else
  290.         clrTopLeft = vbButtonFace
  291.         clrBottomRight = vbButtonFace
  292.     End If
  293.     'Compute location for current date
  294.     i = Weekday(DateSerial(Year(m_CurrDate), Month(m_CurrDate), 1)) - 1
  295.     i = i + (Day(m_CurrDate) - 1)
  296.     X = (i Mod GRID_COLS) * m_nGridWidth
  297.     Y = (i \ GRID_COLS) * m_nGridHeight
  298.     'Draw box around date
  299.     picMonth.Line (X, Y + m_nGridHeight)-Step(0, -m_nGridHeight), clrTopLeft
  300.     picMonth.Line -Step(m_nGridWidth, 0), clrTopLeft
  301.     picMonth.Line -Step(0, m_nGridHeight), clrBottomRight
  302.     picMonth.Line -Step(-m_nGridWidth, 0), clrBottomRight
  303. End Sub
  304.  
  305.