Creating an Outlook like calendar

J

Jesse

I've been tasked to create an Outlook-like calendar that shows the
lenght of various projects over several days or weeks. Based on Duane
Hookum calendar sample, I managed to create the pseudo-monthly view and
the projects in it. If the projects do not go beyond a week, it's all
good. However, if the projects go beyond a week I get into trouble. I
need to figure how to extend the days that fall out of the week when
the project starts. I believe that the approach I took would not let
me do so. The steps I took where the following:

1. Created a query (with date parameters) as the data source.
Following is the query:
PARAMETERS [Starting Date] DateTime, [Ending Date] DateTime;
SELECT DateAdd("d",-Weekday([dtBegin]),([dtBegin])+1) AS WeekOf,
tblProjectSchedule.dtBegin, tblProjectSchedule.dtEnd,
tblProjectSchedule.lutxtProjectID, tblProjectSchedule.txtDescription
FROM tblProjectSchedule WHERE
(((DateAdd("d",-Weekday([dtBegin]),([dtBegin])+1)) Between [Starting
Date] And [Ending Date])) ORDER BY
DateAdd("d",-Weekday([dtBegin]),([dtBegin])+1);

2. I grouped the report by the WeekOf field. On the group header I
placed seven controls to represent every day of the week. Then I added
the following code:
Option Compare Database
Option Explicit
Const cnTwips = 1440

Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
' Comments :
' Parameters:
' Created : 03 Mar 2006 07:36 JA
' Modified :
' --------------------------------------------------

On Error GoTo ErrorHandler
Dim sngOneDay As Single
Dim sngWidth As Single
Dim sngLeft As Single
Dim sngPageWidth As Single
Dim sngPageTwips As Single
Dim sngWidthDiff As Single

sngPageWidth = 9.9167 'Page size
sngPageTwips = sngPageWidth * cnTwips 'Page size as twips
sngOneDay = 2040 'number of twips in one day

sngLeft = DateDiff("d", Me.WeekOf, Me.dtBegin) * sngOneDay
Me.Project.Left = sngLeft

sngWidth = DateDiff("d", Me.dtBegin, Me.dtEnd) * sngOneDay

If sngWidth = 0 Then
sngWidth = sngOneDay
End If

sngWidthDiff = sngPageTwips - sngLeft

If sngWidth > sngWidthDiff Then
Me.Project.Width = sngWidthDiff
Else
Me.Project.Width = sngWidth
End If

Debug.Print Me.Project
Debug.Print vbTab & "Top: " & Project.Top
Debug.Print vbTab & "Left: " & Project.Left
Debug.Print vbTab & "Width: " & Project.Width
Debug.Print vbTab & "Height: " & Project.Height
Debug.Print vbTab & "Count: " & FormatCount

ExitHandler:
Exit Sub

ErrorHandler:
MsgBox "Error " & Err.Number & vbNewLine & Err.Description &
vbNewLine & "In Detail_Format."
Resume ExitHandler

End Sub

Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer)
' Comments :
' Parameters:
' Created : 04 Mar 2006 18:17 JA
' Modified :
' --------------------------------------------------

On Error GoTo ErrorHandler
Me.ScaleMode = 1
Me.ForeColor = 0
'Repeat the following line of code for each vertical line
' 1*1440 represents 1 inch
Me.Line (0 * 1440, 0)-(0 * 1440, 14400) 'Draws line at Left Margin
Me.Line (9.9167 * 1440, 0)-(9.9167 * 1440, 14400) 'At Rigth inch
Me.Line (1.4167 * 1440, 0)-(1.4167 * 1440, 14400)
Me.Line (2.8333 * 1440, 0)-(2.8333 * 1440, 14400)
Me.Line (4.25 * 1440, 0)-(4.25 * 1440, 14400)
Me.Line (5.6667 * 1440, 0)-(5.6667 * 1440, 14400)
Me.Line (7.0833 * 1440, 0)-(7.0833 * 1440, 14400)
Me.Line (8.5 * 1440, 0)-(8.5 * 1440, 14400)

ExitHandler:
Exit Sub

ErrorHandler:
MsgBox "Error " & Err.Number & vbNewLine & Err.Description &
vbNewLine & "In Detail_Print."
Resume ExitHandler

End Sub

3. With some test data that display OK on the screen, I recorded the
following values from the control.
GET-06-277: Muestreo de suelo
Top: 0
Left: 6120
Width: 4080
Height: 300
Count: 1
GET-05-269: Muestreo de suelo
Top: 0
Left: 6120
Width: 4080
Height: 300
Count: 1
GET-06-276: Direct Push
Top: 0
Left: 2040
Width: 2040
Height: 300
Count: 1
GET-06-277: Excavación y remoción de agua del tanque
Top: 0
Left: 6120
Width: 4080
Height: 300
Count: 1
GET-06-274: Geoprobe services
Top: 0
Left: 2040
Width: 12240
Height: 300
Count: 1

The last group entry was cut to accomodate the paper lenght but in
reality it should run over the next week. This is the place where I
stumble. Looking for ideas on how I might tackle it. Thanks.

Jesse
 
D

Duane Hookom

Not sure if this is the same question you asked more recently. I'm not sure
which report this is based on. If it is the rotation report and your bar
would extend beyond the right margins or need to continue on a new line, you
would need to modify your record source to create multiple records from a
single record.

--
Duane Hookom
MS Access MVP
--

I've been tasked to create an Outlook-like calendar that shows the
lenght of various projects over several days or weeks. Based on Duane
Hookum calendar sample, I managed to create the pseudo-monthly view and
the projects in it. If the projects do not go beyond a week, it's all
good. However, if the projects go beyond a week I get into trouble. I
need to figure how to extend the days that fall out of the week when
the project starts. I believe that the approach I took would not let
me do so. The steps I took where the following:

1. Created a query (with date parameters) as the data source.
Following is the query:
PARAMETERS [Starting Date] DateTime, [Ending Date] DateTime;
SELECT DateAdd("d",-Weekday([dtBegin]),([dtBegin])+1) AS WeekOf,
tblProjectSchedule.dtBegin, tblProjectSchedule.dtEnd,
tblProjectSchedule.lutxtProjectID, tblProjectSchedule.txtDescription
FROM tblProjectSchedule WHERE
(((DateAdd("d",-Weekday([dtBegin]),([dtBegin])+1)) Between [Starting
Date] And [Ending Date])) ORDER BY
DateAdd("d",-Weekday([dtBegin]),([dtBegin])+1);

2. I grouped the report by the WeekOf field. On the group header I
placed seven controls to represent every day of the week. Then I added
the following code:
Option Compare Database
Option Explicit
Const cnTwips = 1440

Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
' Comments :
' Parameters:
' Created : 03 Mar 2006 07:36 JA
' Modified :
' --------------------------------------------------

On Error GoTo ErrorHandler
Dim sngOneDay As Single
Dim sngWidth As Single
Dim sngLeft As Single
Dim sngPageWidth As Single
Dim sngPageTwips As Single
Dim sngWidthDiff As Single

sngPageWidth = 9.9167 'Page size
sngPageTwips = sngPageWidth * cnTwips 'Page size as twips
sngOneDay = 2040 'number of twips in one day

sngLeft = DateDiff("d", Me.WeekOf, Me.dtBegin) * sngOneDay
Me.Project.Left = sngLeft

sngWidth = DateDiff("d", Me.dtBegin, Me.dtEnd) * sngOneDay

If sngWidth = 0 Then
sngWidth = sngOneDay
End If

sngWidthDiff = sngPageTwips - sngLeft

If sngWidth > sngWidthDiff Then
Me.Project.Width = sngWidthDiff
Else
Me.Project.Width = sngWidth
End If

Debug.Print Me.Project
Debug.Print vbTab & "Top: " & Project.Top
Debug.Print vbTab & "Left: " & Project.Left
Debug.Print vbTab & "Width: " & Project.Width
Debug.Print vbTab & "Height: " & Project.Height
Debug.Print vbTab & "Count: " & FormatCount

ExitHandler:
Exit Sub

ErrorHandler:
MsgBox "Error " & Err.Number & vbNewLine & Err.Description &
vbNewLine & "In Detail_Format."
Resume ExitHandler

End Sub

Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer)
' Comments :
' Parameters:
' Created : 04 Mar 2006 18:17 JA
' Modified :
' --------------------------------------------------

On Error GoTo ErrorHandler
Me.ScaleMode = 1
Me.ForeColor = 0
'Repeat the following line of code for each vertical line
' 1*1440 represents 1 inch
Me.Line (0 * 1440, 0)-(0 * 1440, 14400) 'Draws line at Left Margin
Me.Line (9.9167 * 1440, 0)-(9.9167 * 1440, 14400) 'At Rigth inch
Me.Line (1.4167 * 1440, 0)-(1.4167 * 1440, 14400)
Me.Line (2.8333 * 1440, 0)-(2.8333 * 1440, 14400)
Me.Line (4.25 * 1440, 0)-(4.25 * 1440, 14400)
Me.Line (5.6667 * 1440, 0)-(5.6667 * 1440, 14400)
Me.Line (7.0833 * 1440, 0)-(7.0833 * 1440, 14400)
Me.Line (8.5 * 1440, 0)-(8.5 * 1440, 14400)

ExitHandler:
Exit Sub

ErrorHandler:
MsgBox "Error " & Err.Number & vbNewLine & Err.Description &
vbNewLine & "In Detail_Print."
Resume ExitHandler

End Sub

3. With some test data that display OK on the screen, I recorded the
following values from the control.
GET-06-277: Muestreo de suelo
Top: 0
Left: 6120
Width: 4080
Height: 300
Count: 1
GET-05-269: Muestreo de suelo
Top: 0
Left: 6120
Width: 4080
Height: 300
Count: 1
GET-06-276: Direct Push
Top: 0
Left: 2040
Width: 2040
Height: 300
Count: 1
GET-06-277: Excavación y remoción de agua del tanque
Top: 0
Left: 6120
Width: 4080
Height: 300
Count: 1
GET-06-274: Geoprobe services
Top: 0
Left: 2040
Width: 12240
Height: 300
Count: 1

The last group entry was cut to accomodate the paper lenght but in
reality it should run over the next week. This is the place where I
stumble. Looking for ideas on how I might tackle it. Thanks.

Jesse
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

My earlier post was Horizontal Line 20
Invalid use of Me keyword 3
Subform in Report is blank 1
VBE tricky question 2
Error message "An error has occured in the script on this page" 1
How to associate a second label to an Option group option? 6
Using Detail.Print 6
Report not printing 0

Top