View Single Post
 
Old 07-10-2004, 05:30 PM
Flyguy's Avatar
Flyguy Flyguy is offline
Lost Soul

Super Moderator
* Guru *
 
Join Date: May 2001
Location: Vorlon
Posts: 19,164
Default Using the MSFlexGrid as a Calendar

Sample using the MSFlexGrid as a Month Calendar like Outlook.
Code:
'--------------------------------------------------------------------------------------- ' Module : Form1 ' DateTime : 11-7-2004 00:28 ' Author : Flyguy ' Purpose : Sample using FlexGrid as Month Calendar '--------------------------------------------------------------------------------------- Option Explicit Private m_lDate As Long ' The date we are working on Private Sub Form_Load() m_lDate = Date DrawGrid m_lDate End Sub Private Sub Command1_Click() m_lDate = DateAdd("m", -1, m_lDate) DrawGrid m_lDate End Sub Private Sub Command2_Click() m_lDate = DateAdd("m", 1, m_lDate) DrawGrid m_lDate End Sub Private Sub Form_Resize() ' I really don't care about errors when resizing On Error Resume Next Command2.Left = Me.ScaleWidth - Command1.Left - Command2.Width With MSFlexGrid1 .Left = Command1.Left .Top = 2 * Command1.Top + Command2.Height .Move .Left, .Top, Me.ScaleWidth - 2 * .Left, Me.ScaleHeight - .Top - .Left End With ' Also update the grid interior SizeGrid End Sub '--------------------------------------------------------------------------------------- ' Procedure : MSFlexGrid1_DblClick ' DateTime : 10-7-2004 23:55 ' Author : Flyguy ' Purpose : To enter some data in the clicked cell '--------------------------------------------------------------------------------------- ' Private Sub MSFlexGrid1_DblClick() Dim lRow As Long Dim lCol As Long Dim sText As String With MSFlexGrid1 lRow = .MouseRow lCol = .MouseCol If lRow / 2 = lRow \ 2 Then lRow = lRow + 1 sText = InputBox(.TextMatrix(lRow - 1, lCol), , .TextMatrix(lRow, lCol)) If StrPtr(sText) <> 0 Then .TextMatrix(lRow, lCol) = sText End With End Sub Private Sub MSFlexGrid1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) SetCellFocus End Sub Private Sub MSFlexGrid1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = vbLeftButton Then SetCellFocus End Sub '--------------------------------------------------------------------------------------- ' Procedure : DrawGrid ' DateTime : 11-7-2004 00:23 ' Author : Flyguy ' Purpose : Draw the calendar for the given month '--------------------------------------------------------------------------------------- ' Private Sub DrawGrid(ByVal theDate As Long) Dim lFirstDate As Long Dim lLastDate As Long Dim lFirstCol As Long Dim lCol As Long, lRow As Long, lRows As Long Dim lDate As Long Me.Caption = Format(theDate, "mmmm yyyy") ' Get the 1st and last day of the month lFirstDate = DateSerial(Year(theDate), Month(theDate), 1) lLastDate = DateSerial(Year(theDate), Month(theDate) + 1, 1) - 1 ' The starting column lFirstCol = Weekday(lFirstDate, vbUseSystemDayOfWeek) - 1 ' Determine the number of weeks lRows = DateDiff("ww", lFirstDate, lLastDate, vbUseSystemDayOfWeek) + 1 With MSFlexGrid1 ' No borders etc to autosize nicely .BorderStyle = flexBorderNone .Appearance = flexFlat .ScrollBars = flexScrollBarNone ' Just some color settings .GridColor = vb3DFace .BackColor = .GridColor ' No highlighting .HighLight = flexHighlightNever .FocusRect = flexFocusLight ' Enable texts to span multiple lines .WordWrap = True ' Number of days in a week ;) .Cols = 7 ' For the date header .Rows = lRows * 2 .Clear lRow = 0 lCol = lFirstCol - 1 For lDate = lFirstDate To lLastDate ' Column and Row counters lCol = lCol + 1 If lCol > 6 Then lRow = lRow + 2 lCol = 0 End If ' Format the date header of the cell .Col = lCol .Row = lRow .TextMatrix(lRow, lCol) = FormatDateTime(lDate, vbShortDate) .CellAlignment = flexAlignRightTop ' Different color for weekend days If Weekday(lDate, vbMonday) > 5 Then .CellBackColor = RGB(239, 239, 239) Else .CellBackColor = vbWhite End If ' Make it yellow when today If lDate = Date Then .CellBackColor = vbYellow ' Format the data cell .Row = lRow + 1 .CellBackColor = vbWhite .CellAlignment = flexAlignLeftTop .CellFontBold = True ' Different color for weekend days If Weekday(lDate, vbMonday) > 5 Then .CellBackColor = RGB(239, 239, 239) Else .CellBackColor = vbWhite End If ' Make it yellow when today If lDate = Date Then .CellBackColor = vbInfoBackground Next lDate ' No fixed columns/rows .FixedRows = 0 .FixedCols = 0 ' Set the initial focus .Col = lFirstCol .Row = 1 SizeGrid .Redraw = True End With End Sub '--------------------------------------------------------------------------------------- ' Procedure : SizeGrid ' DateTime : 11-7-2004 00:23 ' Author : Flyguy ' Purpose : Resize the cells when the grid is resized '--------------------------------------------------------------------------------------- ' Private Sub SizeGrid() Dim lRowHeight As Long Dim lRow As Long ' Don't care about resize errors On Error Resume Next With MSFlexGrid1 .Redraw = False ' Set the width of all columns .ColWidth(-1) = Int(.Width / .Cols) ' Correct the width of last column .ColWidth(.Cols - 1) = .ColWidth(.Cols - 1) + (.Width - .Cols * .ColWidth(.Cols - 1)) ' Calculate the height of the data cells lRowHeight = (.Height - (.Rows / 2) * .RowHeight(0)) / (.Rows / 2) ' Set the height of the data cells For lRow = 1 To .Rows - 1 Step 2 .RowHeight(lRow) = lRowHeight Next lRow .Redraw = True End With End Sub '--------------------------------------------------------------------------------------- ' Procedure : SetCellFocus ' DateTime : 10-7-2004 23:56 ' Author : Flyguy ' Purpose : Make sure to set the focus to the data part '--------------------------------------------------------------------------------------- ' Private Sub SetCellFocus() Dim lRow As Long Dim lCol As Long With MSFlexGrid1 lRow = .MouseRow lCol = .MouseCol If lRow >= 0 And lCol >= 0 Then If lRow / 2 = lRow \ 2 Then lRow = lRow + 1 .Row = lRow .Col = lCol End If End With End Sub
Attached Images
File Type: gif FlexCalendar1.gif (12.9 KB, 597 views)
File Type: gif FlexCalendar2.gif (13.4 KB, 549 views)
Reply With Quote