Abundant Technologies - IT Consulting Experts

 Source Code Library

 Code Details

     
'This section is the UserControl Option Explicit Const m_def_BackColor = &H8000000F Const SELDAYCOLOR = &H808080 Const LIGHTGREY = &HC0C0C0 Const DARKBLUE = &H800000 Const SHADOW = 16 'Shadow Width Type CalendarParm Left As Integer Top As Integer Right As Integer Bottom As Integer CapHeight As Integer DayHeight As Integer CellHeight As Integer CellWidth As Integer xBorder As Integer yBorder As Integer End Type Dim m_cp As CalendarParm Dim m_Days(42) As Date Dim m_DayOffset As Integer Dim CurrDays As Integer Dim ComboEventDisable As Boolean Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) Event Paint() Event AfterUpdate() 'Default Property Values: 'Const m_def_Year = 0 'Const m_def_Month = 0 'Const m_def_Day = 0 'Property Variables: Dim m_BackColor As OLE_COLOR Dim m_Font As Font Dim m_Year As Integer Dim m_Month As Integer Dim m_Day As Integer 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 'MemberInfo=8,0,0,0 Public Property Get BackColor() As OLE_COLOR BackColor = m_BackColor End Property Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR) m_BackColor = New_BackColor PropertyChanged "BackColor" UserControl.BackColor = m_BackColor UserControl_Paint End Property 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 'MemberInfo=6,0,0,0 Public Property Get Font() As Font Set Font = m_Font End Property Public Property Set Font(ByVal New_Font As Font) Set m_Font = New_Font PropertyChanged "Font" End Property 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 'MemberInfo=7,0,0,0 Public Property Get Year() As Integer Year = m_Year End Property Public Property Let Year(ByVal New_Year As Integer) 'only accept date pre loaded in the combox If New_Year >= 1900 And New_Year <= 2100 Then m_Year = New_Year End If RaiseEvent AfterUpdate PropertyChanged "Year" cboYear.ListIndex = m_Year - 1900 End Property 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 'MemberInfo=7,0,0,0 Public Property Get Month() As Integer Month = m_Month End Property Public Property Let Month(ByVal New_Month As Integer) If New_Month >= 1 And New_Month <= 12 Then m_Month = New_Month End If RaiseEvent AfterUpdate PropertyChanged "Month" cboMonth.ListIndex = m_Month - 1 End Property 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 'MemberInfo=7,0,0,0 Public Property Get Day() As Integer If m_Day < 1 Then Day = 0 Else If m_Day > CurrDays + m_DayOffset - 1 Then Day = 0 Else Day = m_Day - m_DayOffset + 1 End If End If End Property Public Property Let Day(ByVal New_Day As Integer) If New_Day >= 1 And New_Day < CurrDays + m_DayOffset - 1 Then m_Day = New_Day + m_DayOffset - 1 End If RaiseEvent AfterUpdate PropertyChanged "Day" UserControl_Paint End Property 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 'MemberInfo=5 Public Sub Refresh() End Sub 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 'MemberInfo=14 Public Sub Today() cboYear.ListIndex = Val(Format(Now, "yyyy")) - 1900 cboMonth.ListIndex = Val(Format(Now, "m")) - 1 m_Day = Int(Format(Now, "d")) + Weekday(DateSerial(Val(Format(Now, "yyyy")), Val(Format(Now, "m")), 1)) - 1 Call FillDays(m_Days(), DateSerial(m_Year, m_Month, 1)) Call UserControl_Paint RaiseEvent AfterUpdate End Sub Public Sub NextDay() 'if the next day is a new month there is lots to do If Format(m_Days(m_Day + 1), "m") <> Format(DateSerial(m_Year, m_Month, 1), "m") Then m_Year = Format(m_Days(m_Day + 1), "yyyy") m_Month = Format(m_Days(m_Day + 1), "m") m_Day = Format(m_Days(m_Day + 1), "d") ComboEventDisable = True cboYear.ListIndex = m_Year - 1900 cboMonth.ListIndex = m_Month - 1 ComboEventDisable = False Call FillDays(m_Days(), DateSerial(m_Year, m_Month, 1)) m_Day = m_Day + m_DayOffset - 1 Call FillDays(m_Days(), DateSerial(m_Year, m_Month, 1)) Else m_Day = m_Day + 1 End If Call FillDays(m_Days(), DateSerial(m_Year, m_Month, 1)) Call UserControl_Paint RaiseEvent AfterUpdate End Sub Private Sub cboMonth_Click() If ComboEventDisable Then Exit Sub m_Month = cboMonth.ListIndex + 1 Call FillDays(m_Days(), DateSerial(m_Year, m_Month, 1)) m_Day = 0 Call UserControl_Paint RaiseEvent AfterUpdate End Sub Private Sub cboYear_Click() If ComboEventDisable Then Exit Sub m_Year = cboYear.ListIndex + 1900 Call FillDays(m_Days(), DateSerial(m_Year, m_Month, 1)) m_Day = 0 Call UserControl_Paint RaiseEvent AfterUpdate End Sub Private Sub UserControl_Initialize() Dim i As Integer 'load month and year comboboxes ComboEventDisable = True For i = 1900 To 2100 cboYear.AddItem Format$(i) Next cboYear.ListIndex = Val(Format(Now, "yyyy")) - 1900 m_Year = cboYear.ListIndex + 1900 For i = 1 To 12 cboMonth.AddItem Format(DateSerial(2000, i, 1), "mmmm") Next cboMonth.ListIndex = Val(Format(Now, "m")) - 1 m_Month = cboMonth.ListIndex + 1 m_Day = Int(Format(Now, "d")) + Weekday(DateSerial(Val(Format(Now, "yyyy")), Val(Format(Now, "m")), 1)) - 1 Call FillDays(m_Days(), DateSerial(m_Year, m_Month, 1)) ComboEventDisable = False End Sub Private Sub UserControl_InitProperties() m_BackColor = m_def_BackColor Set m_Font = Ambient.Font ' m_Year = m_def_Year ' m_Month = m_def_Month ' m_Day = m_def_Day End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor) Set m_Font = PropBag.ReadProperty("Font", Ambient.Font) ' m_Year = PropBag.ReadProperty("Year", m_def_Year) ' m_Month = PropBag.ReadProperty("Month", m_def_Month) ' m_Day = PropBag.ReadProperty("Day", m_def_Day) End Sub Private Sub UserControl_Resize() m_cp.CapHeight = 700 m_cp.CellWidth = Int(UserControl.Width / 7.3) m_cp.CellHeight = (UserControl.Height - m_cp.CapHeight) / 6.2 m_cp.xBorder = UserControl.Width / 50 m_cp.yBorder = UserControl.Height / 50 cboYear.Left = UserControl.Width - m_cp.xBorder - cboYear.Width cboMonth.Left = UserControl.Width - (2 * m_cp.xBorder) - cboYear.Width - cboMonth.Width UserControl_Paint End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor) Call PropBag.WriteProperty("Font", m_Font, Ambient.Font) Call PropBag.WriteProperty("Year", m_Year, m_Year) Call PropBag.WriteProperty("Month", m_Month, m_Month) Call PropBag.WriteProperty("Day", m_Day, m_Day) End Sub Private Sub UserControl_Paint() Dim x As Integer Dim y As Integer Dim Selx As Integer Dim Sely As Integer Dim strCurrent As String UserControl.Cls 'draw border around calendar ' Line (0, 0)-(Extender.Width - 15, Extender.Height - 15), vbBlack, B 'draw current month and year strCurrent = Format(DateSerial(m_Year, m_Month, 1), "mmmm yyyy") UserControl.FontBold = True UserControl.FontSize = UserControl.Width / 400 If UserControl.FontSize < 12 Then UserControl.FontSize = 12 UserControl.ForeColor = DARKBLUE CurrentX = (UserControl.Width - ((m_cp.xBorder) + cboYear.Width + cboMonth.Width + (12 * UserControl.FontSize * Len(strCurrent)))) / 2 + m_cp.xBorder CurrentY = 100 Print strCurrent 'highlight selected day If m_Day <> 0 Then If m_Day Mod 7 = 0 Then Sely = m_Day / 7 Selx = 7 Else Sely = (Int(m_Day / 7)) + 1 Selx = Round(((m_Day / 7) - Int(m_Day / 7)) * 7) End If End If 'draw calendar For y = 1 To 6 For x = 1 To 7 'days grid If x = Selx And y = Sely Then 'Selected cell Line (((Selx - 1) * m_cp.CellWidth) + m_cp.xBorder, ((Sely - 1) * m_cp.CellHeight) + m_cp.CapHeight)-(((Selx - 1) * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder, ((Sely - 1) * m_cp.CellHeight) + m_cp.CellHeight + m_cp.CapHeight), SELDAYCOLOR, BF Else 'main grey cell Line (((x - 1) * m_cp.CellWidth) + m_cp.xBorder, ((y - 1) * m_cp.CellHeight) + m_cp.CapHeight)-(((x - 1) * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder, ((y - 1) * m_cp.CellHeight) + m_cp.CellHeight + m_cp.CapHeight), LIGHTGREY, BF 'main cell border Line (((x - 1) * m_cp.CellWidth) + m_cp.xBorder, ((y - 1) * m_cp.CellHeight) + m_cp.CapHeight)-(((x - 1) * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder, ((y - 1) * m_cp.CellHeight) + m_cp.CellHeight + m_cp.CapHeight), vbBlack, B End If 'inside white cell Line (((x - 1) * m_cp.CellWidth) + m_cp.xBorder + SHADOW, ((y - 1) * m_cp.CellHeight) + m_cp.CapHeight + SHADOW)-(((x - 1) * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder, ((y - 1) * m_cp.CellHeight) + m_cp.CellHeight + m_cp.CapHeight), vbWhite, B 'day numbers CurrentX = ((x - 1) * m_cp.CellWidth) + m_cp.xBorder + (m_cp.CellWidth / 12) CurrentY = ((y - 1) * m_cp.CellHeight) + m_cp.CapHeight + (m_cp.CellHeight / 24) UserControl.FontBold = False UserControl.FontSize = 8 If Format(m_Days(x + ((y - 1) * 7)), "mmmm") = cboMonth.Text Then UserControl.ForeColor = DARKBLUE Else UserControl.ForeColor = SELDAYCOLOR End If Print Format(m_Days(x + ((y - 1) * 7)), "d") If y = 1 Then 'header grid Line (((x - 1) * m_cp.CellWidth) + m_cp.xBorder, m_cp.CapHeight - 200)-(((x - 1) * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder, m_cp.CapHeight), LIGHTGREY, BF 'inside white cell Line (((x - 1) * m_cp.CellWidth) + m_cp.xBorder + (m_cp.CellWidth / 48), m_cp.CapHeight - 200 + (m_cp.CellHeight / 48))-(((x - 1) * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder, m_cp.CapHeight), vbWhite, B 'main black cell Line (((x - 1) * m_cp.CellWidth) + m_cp.xBorder, m_cp.CapHeight - 200)-(((x - 1) * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder, m_cp.CapHeight), vbBlack, B 'days of the week CurrentX = ((x - 1) * m_cp.CellWidth) + m_cp.xBorder + (m_cp.CellWidth / 3) CurrentY = m_cp.CapHeight - 185 UserControl.FontBold = True UserControl.FontSize = 8 UserControl.ForeColor = vbBlack Print Format(DateSerial(2000, 1, x + 1), "ddd") End If Next Next If m_Day <> 0 Then 'inside black cell Line (((Selx - 1) * m_cp.CellWidth) + m_cp.xBorder + SHADOW, ((Sely - 1) * m_cp.CellHeight) + m_cp.CapHeight + SHADOW)-(((Selx - 1) * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder, ((Sely - 1) * m_cp.CellHeight) + m_cp.CellHeight + m_cp.CapHeight), vbBlack, B End If 'dark shadowing around outside Line (m_cp.xBorder, m_cp.CapHeight - 200)-((6 * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder, (5 * m_cp.CellHeight) + m_cp.CellHeight + m_cp.CapHeight), vbBlack, B Line (m_cp.xBorder, m_cp.CapHeight - 200)-((6 * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder + (m_cp.CellWidth / 128), (5 * m_cp.CellHeight) + m_cp.CellHeight + m_cp.CapHeight + (m_cp.CellHeight / 64)), vbBlack, B Line (m_cp.xBorder, m_cp.CapHeight - 200)-((6 * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder + (m_cp.CellWidth / 64), (5 * m_cp.CellHeight) + m_cp.CellHeight + m_cp.CapHeight + (m_cp.CellHeight / 32)), vbBlack, B End Sub Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 'Cause control AfterUpdate event if user clicks inside square. If x > m_cp.xBorder And y > m_cp.CapHeight And x < ((6 * m_cp.CellWidth) + m_cp.CellWidth + m_cp.xBorder) And y < ((5 * m_cp.CellHeight) + m_cp.CellHeight + m_cp.CapHeight) Then m_Day = Int((x - m_cp.xBorder) / m_cp.CellWidth) + (Int((y - m_cp.CapHeight) / m_cp.CellHeight) * 7) + 1 End If If Format(m_Days(m_Day), "m") <> Format(DateSerial(m_Year, m_Month, 1), "m") Then m_Year = Format(m_Days(m_Day), "yyyy") m_Month = Format(m_Days(m_Day), "m") m_Day = Format(m_Days(m_Day), "d") ComboEventDisable = True cboYear.ListIndex = m_Year - 1900 cboMonth.ListIndex = m_Month - 1 ComboEventDisable = False 'need to do Filldays now to get the dayoffset Call FillDays(m_Days(), DateSerial(m_Year, m_Month, 1)) m_Day = m_Day + m_DayOffset - 1 'do it again to make the new month Call FillDays(m_Days(), DateSerial(m_Year, m_Month, 1)) End If Call UserControl_Paint RaiseEvent AfterUpdate End Sub Private Sub FillDays(ByRef dDays() As Date, dCurrDate As Date) Dim dFirstCell As Date Dim dNext As Date Dim i As Integer 'fill the array of 42 dates If Weekday(dCurrDate) = 1 Then m_DayOffset = 8 Else m_DayOffset = Weekday(dCurrDate) End If dNext = DateAdd("m", 1, dCurrDate) CurrDays = dNext - dCurrDate Erase m_Days dFirstCell = DateAdd("d", -m_DayOffset + 1, dCurrDate) For i = 1 To 42 dDays(i) = DateAdd("d", i - 1, dFirstCell) Next End Sub 'This section is Dates Property Page Option Explicit Private Sub txtDay_Change() Changed = True End Sub Private Sub txtMonth_Change() Changed = True End Sub Private Sub txtYear_Change() Changed = True End Sub Private Sub PropertyPage_ApplyChanges() SelectedControls(0).Day = txtDay.Text SelectedControls(0).Month = txtMonth.Text SelectedControls(0).Year = txtYear.Text End Sub Private Sub PropertyPage_SelectionChanged() txtDay.Text = SelectedControls(0).Day txtMonth.Text = SelectedControls(0).Month txtYear.Text = SelectedControls(0).Year End Sub

Mail To: info@3pc.com