Programming Tool Box/SIMS_2.iso/code/design/calend/calendar.frm

Visual Basic Form | 1995-02-27 | 11.9 KB | 374 lines

VERSION 2.00
Begin Form Calendar
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Double
   Caption         =   "Calendar"
   ClientHeight    =   2220
   ClientLeft      =   2715
   ClientTop       =   3555
   ClientWidth     =   2985
   ClipControls    =   0   'False
   Height          =   2625
   Icon            =   CALENDAR.FRX:0000
   Left            =   2655
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   2220
   ScaleWidth      =   2985
   Top             =   3210
   Width           =   3105
   Begin CommandButton NextYear
      Caption         =   ">>"
      Height          =   285
      Left            =   2505
      TabIndex        =   4
      Top             =   1875
      Width           =   400
   End
   Begin CommandButton NextMonth
      Caption         =   ">"
      Height          =   285
      Left            =   2070
      TabIndex        =   3
      Top             =   1875
      Width           =   400
   End
   Begin CommandButton PreviousMonth
      Caption         =   "<"
      Height          =   285
      Left            =   510
      TabIndex        =   1
      Top             =   1875
      Width           =   400
   End
   Begin CommandButton PreviousYear
      Caption         =   "<<"
      Height          =   285
      Left            =   75
      TabIndex        =   0
      Top             =   1875
      Width           =   400
   End
   Begin CommandButton EnterDate
      Caption         =   "New &Date..."
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   285
      Left            =   945
      TabIndex        =   2
      Top             =   1875
      Width           =   1100
   End
   Begin Line Line1
      BorderColor     =   &H00808080&
      X1              =   75
      X2              =   2881
      Y1              =   480
      Y2              =   480
   End
   Begin Label DateDisplay
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      ForeColor       =   &H00FF0000&
      Height          =   215
      Left            =   0
      TabIndex        =   13
      Top             =   50
      Width           =   2985
   End
   Begin Label DayLabel
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   210
      Index           =   0
      Left            =   90
      TabIndex        =   5
      Top             =   585
      Width           =   375
   End
   Begin Label Label1
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Sat"
      Height          =   285
      Index           =   6
      Left            =   2520
      TabIndex        =   12
      Top             =   270
      Width           =   375
   End
   Begin Label Label1
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Fri"
      Height          =   285
      Index           =   5
      Left            =   2115
      TabIndex        =   11
      Top             =   270
      Width           =   375
   End
   Begin Label Label1
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Thu"
      Height          =   285
      Index           =   4
      Left            =   1710
      TabIndex        =   10
      Top             =   270
      Width           =   375
   End
   Begin Label Label1
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Wed"
      Height          =   285
      Index           =   3
      Left            =   1305
      TabIndex        =   9
      Top             =   270
      Width           =   375
   End
   Begin Label Label1
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Tue"
      Height          =   285
      Index           =   2
      Left            =   900
      TabIndex        =   8
      Top             =   270
      Width           =   375
   End
   Begin Label Label1
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Mon"
      Height          =   285
      Index           =   1
      Left            =   495
      TabIndex        =   7
      Top             =   270
      Width           =   375
   End
   Begin Label Label1
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Sun"
      ForeColor       =   &H000000FF&
      Height          =   285
      Index           =   0
      Left            =   90
      TabIndex        =   6
      Top             =   270
      Width           =   375
   End
DefInt A-Z
Option Explicit
Dim PreviousIndex As Integer
Dim InputDate     As Variant
Dim CurrentDay    As Integer
Dim CurrentMonth  As Integer
Dim CurrentYear   As Integer
Rem Constants for 3D look.
Const BUTTON_FACE = &H8000000F
Const FIXED_DOUBLE = 3
Const DS_MODALFRAME = &H80&
Const CTL3D_ALL = &HFFFF
Const GWL_STYLE = (-16)
Const GWW_HINSTANCE = (-6)
Rem MessageBox Constant.
Const MB_ICONINFORMATION = 64
Declare Function Ctl3dRegister Lib "CTL3D.DLL" (ByVal hInst)
Declare Function Ctl3dUnregister Lib "CTL3D.DLL" (ByVal hInst)
Declare Function Ctl3dAutoSubclass Lib "CTL3D.DLL" (ByVal hInst)
Declare Function Ctl3dSubclassDlgEx Lib "CTL3D.DLL" (ByVal hWnd, ByVal Flags&)
Declare Function GetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Long
Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
Declare Function SetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long
Rem Removing some menus.
Declare Function GetSystemMenu% Lib "User" (ByVal hWnd%, ByVal bRevert%)
Declare Function RemoveMenu% Lib "User" (ByVal hMenu%, ByVal nPosition%, ByVal wFlags%)
Const MF_BYPOSITION = &H400
Sub DayLabel_Click (Index As Integer)
HighLight DayLabel(Index)
End Sub
Sub DayLabel_DblClick (Index As Integer)
MsgBox DateDisplay, MB_ICONINFORMATION, "Calendar"
Unload Me
End Sub
Sub DisplayCalendar ()
Dim i           As Integer
Dim WkDay       As Integer
Dim DateToCheck As String
Dim StartingDay As Integer
Dim ValidDate   As Integer
CurrentDay = Day(InputDate)
CurrentMonth = Month(InputDate)
CurrentYear = Year(InputDate)
Rem Get the weekday to start the calendar.
StartingDay = Weekday(Month(InputDate) & "/1/" & Year(InputDate))
Rem Hide the beginning days not used.
For i = 0 To StartingDay - 1
  DayLabel(i).Visible = False
Rem Loop  until the date is invalid.
Rem This method saves a lot of code, ex: checking for number of days in the month, Leap year, etc.
  WkDay = WkDay + 1
  DateToCheck = Month(InputDate) & "/" & WkDay & "/" & Year(InputDate)
  On Error Resume Next
  ValidDate = Weekday(DateToCheck)
  If Err Then
    Exit Do
  Else
    DayLabel(StartingDay) = Day(DateToCheck)
    DayLabel(StartingDay).Visible = True
    If DayLabel(StartingDay) = CurrentDay Then
      HighLight DayLabel(StartingDay)
    End If
  End If
  StartingDay = StartingDay + 1
Rem Hide the remaining controls that are not used.
For i = StartingDay To 37
  DayLabel(i).Visible = False
End Sub
Sub EnterDate_Click ()
Dim DefaultDate As String
DefaultDate = Format(Str$(CurrentMonth) & "/" & Str$(CurrentDay) & "/" & Str$(CurrentYear), "m/d/yy")
InputDate = InputBox("Enter Date: ", "Calendar", DefaultDate)
Rem Cancel was pressed or no date was entered.
If InputDate = "" Then
  Exit Sub
End If
Rem Check for a valid date.
If Not IsDate(InputDate) Then
  MsgBox InputDate & " is not a valid date.", 16, "Calendar"
  Exit Sub
End If
DisplayCalendar
End Sub
Sub Form_Load ()
Dim i           As Integer
Dim J           As Integer
Dim CurrentTop  As Single
Dim DayCount    As Integer
Dim CurrentLeft As Single
Rem Display the calendar using Today's Date.
CurrentMonth = Month(Now)
CurrentDay = Day(Now)
CurrentYear = Year(Now)
Rem remove some items from the system menu.
RemoveSysMenuItems Me
Rem Register Ctl3D.
RegCtl3D (Me.hWnd)
FrmCtl3d Me
Rem Center the form.
Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
Rem Position the first Label Control.
DayLabel(0).Move 90, 585, 375, 210
DayLabel(0).Alignment = 2
CurrentLeft = DayLabel(0).Left
CurrentTop = DayLabel(0).Top
Rem Dynamically load the rest of the label controls.
For J = 1 To 6
  For i = 1 To 7
    If DayCount = 37 Then
      InputDate = Date
      DisplayCalendar
      Exit Sub
    End If
    DayCount = DayCount + 1
    Load DayLabel(DayCount)
    If DayCount Mod 7 = 1 Then ' Sunday
      DayLabel(DayCount).ForeColor = &HFF& ' Red
    End If
    DayLabel(DayCount).Move CurrentLeft, CurrentTop
    CurrentLeft = CurrentLeft + DayLabel(0).Width + 30
  Next
  CurrentTop = CurrentTop + DayLabel(0).Height
  CurrentLeft = DayLabel(0).Left
End Sub
Sub Form_QueryUnload (Cancel As Integer, UnloadMode As Integer)
UnregCtl3D (Me.hWnd)
End Sub
Sub FrmCtl3d (Frm As Form)
Dim rc            As Integer
Dim hWnd          As Integer
Dim BorderStyle   As Long
Rem Get the form's hWnd property.
hWnd = Frm.hWnd
If Frm.BorderStyle = FIXED_DOUBLE Then
  Frm.BackColor = BUTTON_FACE
  BorderStyle = GetWindowLong(hWnd, GWL_STYLE)
  BorderStyle = BorderStyle Or DS_MODALFRAME
  BorderStyle = SetWindowLong(hWnd, GWL_STYLE, BorderStyle)
  rc = Ctl3dSubclassDlgEx(hWnd, &H0)
End If
End Sub
Sub HighLight (Ctl As Control)
DayLabel(PreviousIndex).BorderStyle = 0
DayLabel(PreviousIndex).FontBold = False
Ctl.BorderStyle = 1
Ctl.FontBold = True
PreviousIndex = Ctl.Index
CurrentDay = Ctl.Caption
DateDisplay = Format(Str$(CurrentMonth) & Str$(CurrentDay) & Str$(CurrentYear), "Long Date")
End Sub
Sub NextMonth_Click ()
InputDate = Str$(CurrentMonth) & "/" & Str$(CurrentDay) & "/" & Str$(CurrentYear)
InputDate = DateAdd("m", 1, InputDate)
DisplayCalendar
Calendar.Refresh
End Sub
Sub NextYear_Click ()
InputDate = Str$(CurrentMonth) & "/" & Str$(CurrentDay) & "/" & Str$(CurrentYear)
InputDate = DateAdd("yyyy", 1, InputDate)
DisplayCalendar
Calendar.Refresh
End Sub
Sub PreviousMonth_Click ()
InputDate = Str$(CurrentMonth) & "/" & Str$(CurrentDay) & "/" & Str$(CurrentYear)
InputDate = DateAdd("m", -1, InputDate)
DisplayCalendar
Calendar.Refresh
End Sub
Sub PreviousYear_Click ()
InputDate = Str$(CurrentMonth) & "/" & Str$(CurrentDay) & "/" & Str$(CurrentYear)
InputDate = DateAdd("yyyy", -1, InputDate)
DisplayCalendar
Calendar.Refresh
End Sub
Sub RegCtl3D (hWnd As Integer)
Dim Inst   As Integer
Dim rc     As Integer
Inst = GetWindowWord(hWnd, GWW_HINSTANCE)
rc = Ctl3dRegister(Inst)
rc = Ctl3dAutoSubclass(Inst)
End Sub
Sub RemoveSysMenuItems (Frm As Form)
Dim rc          As Integer
Dim SysMenuhWnd As Integer
Rem Get the hWnd to the form's system menu.
SysMenuhWnd = GetSystemMenu(Frm.hWnd, False)
Rem Remove all but the Close and Move menu options.
rc = RemoveMenu(SysMenuhWnd, 8, MF_BYPOSITION)
rc = RemoveMenu(SysMenuhWnd, 7, MF_BYPOSITION)
rc = RemoveMenu(SysMenuhWnd, 5, MF_BYPOSITION)
End Sub
Sub UnregCtl3D (hWnd As Integer)
Dim hInst   As Integer
Dim rc      As Integer
hInst = GetWindowWord(hWnd, GWW_HINSTANCE)
rc = Ctl3dUnregister(hInst)
End Sub