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

Text File | 1995-02-27 | 12KB | 472 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
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)

Hide

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
Next

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.
Do

  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

Loop

Rem Hide the remaining controls that are not used.
For i = StartingDay To 37
  DayLabel(i).Visible = False
Next

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
Next

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