Option Compare Database
Option Explicit
' data access objects needed
Dim mdbT As DAO.Database ' Target DB w/ unit & period tbls, default CurrentDb
Dim mrsU As DAO.Recordset ' Unit recordset
Dim mrsP As DAO.Recordset ' Period recordset
' Constants to identify the tables/queries
' Replace these with the names specific to
' your own application (see user manual).
' Note that the UnitRS can be either a table name,
' or saved query, or a SQL statement.
' Both recordsets must include the Primary Key field.
' The unit set must also include a display field, which
' may or may not be the same as the primary key.
' The period set must include the Primary Key field and
' both the FromDate field and the ThruDate field.
Const cUnitRS As String = "SELECT * FROM tblUnit ORDER BY Unit;"
' You must use a table or query name for the period,
' since a SQL statement that limits the period recordset
' to the currently displayed date range is created at run time.
Const cPeriodRS As String = "tblHourPeriod"
' constants for the names of the primary key fields
Const cUnitPK As String = "UnitID"
Const cPeriodPK As String = "PeriodID"
' constants for the field to display from the unit set
' note that this can be the same as the primary key
' but can be another field as well (as in the default)
Const cUnitDisplayFld As String = "Unit"
' constants for the data type of the PK fields
' DesGrid only supports single field primary keys
' of Number or Text data types. If your primary
' key fields are text fields, use the value "String",
' otherwise leave them as "Numeric".
Const cUnitPKDataType As String = "Numeric"
Const cPeriodPKDataType As String = "Numeric"
' constants for the names of the date fields used
' in the period table. These must be of data type
' Date/Time and there must be two of them:
' one for the FromDate (starting date) and
' one for the ThruDate (ending date)
Const cFromFld As String = "FromDate"
Const cThruFld As String = "ThruDate"
Const cColorKeyFld As String = "ColorKey"
' constant for the name of the color key table
Const cColorTbl As String = "trefColorKey"
' variables to hold selected dates and units
Dim mdSelFrom As Date
Dim mdSelThru As Date
Dim mcolSelUnits As New Collection
' array for currently displayed dates
Dim madDisplay(1 To 32) As Date
' constant for special effect for selected image boxes
Const dsRaised As Long = 1
Const dsSunken As Long = 2
Const dsEtched As Long = 3
' stores true if the grid is clear
' we check this before running code to
' clear the grid (speeds scrolling)
Dim mfGridClear As Boolean
' width (in twips) of a day toggle
Const cHourW As Integer = 288
' number of image boxes in a row
Const cNumImgPerRow As Integer = 32
' dummy value for date variables
Const cBlankDate As Date = #1/1/100#
' variable to store state of selected grid boxes
Dim mfSelectedGrid As Boolean
Private Sub Form_Load()
Dim dOpen As Date
' initialize
mdSelFrom = cBlankDate
mdSelThru = cBlankDate
mfSelectedGrid = False
' fill the recordsets
LoadData
' format calendar portion of the form
' if a date was passed in OpenArgs, use that, else use Date
If Not IsDate(OpenArgs) Then
dOpen = DateSerial(Year(Date), Month(Date), Day(Date)) + TimeSerial(Hour(Time), 0, 0)
SetupCal dOpen
Else
dOpen = CDate(OpenArgs)
dOpen = DateSerial(Year(dOpen), Month(dOpen), Day(dOpen)) + TimeSerial(Hour(dOpen), 0, 0)
SetupCal dOpen
End If
' format unit list portion of the form
FillUnits mrsU.Fields(cUnitPK)
' you might want to clear the grid instead
' depending on how you want the form to initialize
DrawGrid
' set up the color key from table data
GetColorKeyCaptions
End Sub
Public Function DrawGrid() As Boolean
' puts colored diamonds and arrows on the grid
' according to data in the period recordset
On Error GoTo ErrLine
Dim sqlU As String
Dim x As Integer, iCol As Integer
Dim Y As Integer, sColor As String
Dim iImgFirst As Integer, iImgLast As Integer
Dim sUnitID As String
Dim fFromOff As Boolean, fThruOff As Boolean
Dim iFirstInRow As Integer, iTimeUnit As Integer
Dim tgl As ToggleButton
' open a recordset of periods in the current date range
sqlU = "SELECT " & cUnitPK & ", " & cColorKeyFld & ", " & _
cFromFld & ", " & cThruFld & " FROM " & cPeriodRS & _
" WHERE (" & cFromFld & " <= #" & madDisplay(cNumImgPerRow) & "# " & _
"AND " & cThruFld & " >= #" & madDisplay(1) & "# " & _
"AND (" & EnumUnits & ")) " & _
"ORDER BY " & cUnitPK
Set mrsP = mdbT.OpenRecordset(sqlU)
With mrsP
' exit if no records
If (.BOF And .EOF) Then
On Error Resume Next
.Close
Set mrsP = Nothing
ClearGrid
DisplayGrid True
DisplaySelectedGrid
GoTo ExitLine
End If
' work through the records, drawing arrows/diamonds on the appropriate row
ClearGrid
.MoveFirst
Do Until .EOF ' if no period for this unit, on to next unit toggle
' find the row number that matches the current record
For x = 1 To 10
Set tgl = Me.Controls("tglUnit" & Format(x, "00"))
If tgl.Tag = .Fields(cUnitPK) Then
Exit For
End If
Next x
' check to see if the from/thru dates are off screen
fFromOff = (.Fields(cFromFld) < madDisplay(1))
fThruOff = (.Fields(cThruFld) > madDisplay(cNumImgPerRow) + 1)
' Determine which image box represents our first date
iFirstInRow = ((x - 1) * cNumImgPerRow) + 1
If fFromOff Then
iTimeUnit = 0
Else
Select Case grpHour
Case 1
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cFromFld)) / 60
Case 2
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cFromFld)) / 30
Case 3
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cFromFld)) / 15
End Select
End If
iImgFirst = iFirstInRow + iTimeUnit
' determine which image box represents our last date
If .Fields(cThruFld) > madDisplay(cNumImgPerRow) Then
iImgLast = x * cNumImgPerRow
Else
Select Case grpHour
Case 1
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cThruFld)) / 60
Case 2
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cThruFld)) / 30
Case 3
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cThruFld)) / 15
End Select
' remove the '- 1' from the following line if you want the arrow to
' go through the ending time field
iImgLast = iFirstInRow + (iTimeUnit - 1)
End If
' draw the appropriate symbol
sColor = .Fields(cColorKeyFld)
If iImgFirst >= iImgLast Then
' one-unit period, so use a diamond
SetPic iImgFirst, sColor, "D"
Else
' multi-day period, so line w/arrows
If fFromOff Then
SetPic iImgFirst, sColor, "B"
Else
SetPic iImgFirst, sColor, "L"
End If
If fThruOff Then
If (.Fields(cFromFld) = madDisplay(cNumImgPerRow)) Then
SetPic iImgLast, sColor, "L"
Else
SetPic iImgLast, sColor, "B"
End If
Else
SetPic iImgLast, sColor, "R"
End If
' now the bar in between the end points
For Y = (iImgFirst + 1) To (iImgLast - 1)
SetPic Y, sColor, "B"
Next Y
End If
.MoveNext
Loop
End With
DisplayGrid True
mfGridClear = False
DisplaySelectedGrid
DrawGrid = True
ExitLine:
Exit Function
ErrLine:
DrawGrid = False
Resume ExitLine
End Function
Private Function DisplaySelectedGrid() As Boolean
' Sets the special effect of selected grid image boxes
' to dsSunken. Note that this function is cosmetic, since
' there may be selected units not diplayed.
' Returns True if successful, false on error
On Error GoTo ErrLine
Dim iReturn As Integer
' loop counters
Dim iUnitTgl As Integer, x As Integer
' unit toggle, image box
Dim tglU As ToggleButton, imgX As Image
' image box numbers
Dim iFstImg As Integer, iLstImg As Integer
' booleans to determine displayability of arrows
Dim fFirstOff As Boolean, fLastOff As Boolean
Dim fBigWide As Boolean ' a range that spans beyond both sides of the grid
Dim iInterval As Integer
' make sure none are sunken
If mfSelectedGrid Then
For x = 1 To 320
Set imgX = Me.Controls("img" & Format(x, "000"))
imgX.SpecialEffect = dsEtched
Next x
End If
' if no date is selected or no units selected, exit
If ((mdSelFrom = cBlankDate) Or (mcolSelUnits.Count = 0)) Then
iReturn = 0
mfSelectedGrid = False
GoTo ExitLine
Else
mfSelectedGrid = True
End If
' check if the from/thru dates are off screen
' fFirstOff is True if the first selected date has been scrolled off screen
fFirstOff = ((mdSelFrom < madDisplay(1)) Or _
(mdSelFrom > madDisplay(cNumImgPerRow)))
' fLastOff is True if the last selected date has been scrolled off screen
fLastOff = ((mdSelThru > madDisplay(cNumImgPerRow) + 1) Or _
((mdSelThru <= madDisplay(1)) And _
(mdSelThru <> cBlankDate)))
' fBigWide is True if both the first and last dates are off screen (so just a big wide bar)
fBigWide = (mdSelFrom < madDisplay(1) And mdSelThru > madDisplay(cNumImgPerRow))
If (fFirstOff And fLastOff) And Not fBigWide Then
' don't draw an arrow
Else
' loop through the unit toggles, looking for selected ones
For iUnitTgl = 1 To 10
Set tglU = Me.Controls("tglUnit" & Format$(iUnitTgl, "00"))
If tglU Then
' here we figure out the first and last image boxes
Select Case grpHour
Case 1: iInterval = 60
Case 2: iInterval = 30
Case 3: iInterval = 15
End Select
' clean the date values
mdSelThru = DateSerial(Year(mdSelThru), Month(mdSelThru), Day(mdSelThru)) + _
TimeSerial(Hour(mdSelThru), Minute(mdSelThru), 0)
mdSelFrom = DateSerial(Year(mdSelFrom), Month(mdSelFrom), Day(mdSelFrom)) + _
TimeSerial(Hour(mdSelFrom), Minute(mdSelFrom), 0)
If mdSelThru <= DateAdd("n", iInterval, mdSelFrom) Then
' diamond
iFstImg = ((iUnitTgl - 1) * cNumImgPerRow) + ToggleNumFromDate(mdSelFrom)
Set imgX = Me.Controls("img" & Format(iFstImg, "000"))
imgX.SpecialEffect = dsSunken
Else
' arrow
If fFirstOff Then
iFstImg = ((iUnitTgl - 1) * cNumImgPerRow) + 1
Else
iFstImg = ((iUnitTgl - 1) * cNumImgPerRow) + ToggleNumFromDate(mdSelFrom)
End If
If fLastOff Then
iLstImg = iUnitTgl * cNumImgPerRow
Else
iLstImg = ((iUnitTgl - 1) * cNumImgPerRow) + ToggleNumFromDate(mdSelThru)
End If
iLstImg = iLstImg - 1
For x = iFstImg To iLstImg
Set imgX = Me.Controls("img" & Format(x, "000"))
imgX.SpecialEffect = dsSunken
Next x
End If
End If
Next iUnitTgl
End If
mfGridClear = False
DisplaySelectedGrid = True
ExitLine:
Exit Function
ErrLine:
DisplaySelectedGrid = False
Resume ExitLine
End Function
[quote]
Option Compare Database
Option Explicit
' data access objects needed
Dim mdbT As DAO.Database ' Target DB w/ unit & period tbls, default CurrentDb
Dim mrsU As DAO.Recordset ' Unit recordset
Dim mrsP As DAO.Recordset ' Period recordset
' Constants to identify the tables/queries
' Replace these with the names specific to
' your own application (see user manual).
' Note that the UnitRS can be either a table name,
' or saved query, or a SQL statement.
' Both recordsets must include the Primary Key field.
' The unit set must also include a display field, which
' may or may not be the same as the primary key.
' The period set must include the Primary Key field and
' both the FromDate field and the ThruDate field.
Const cUnitRS As String = "SELECT * FROM tblUnit ORDER BY Unit;"
' You must use a table or query name for the period,
' since a SQL statement that limits the period recordset
' to the currently displayed date range is created at run time.
Const cPeriodRS As String = "tblHourPeriod"
' constants for the names of the primary key fields
Const cUnitPK As String = "UnitID"
Const cPeriodPK As String = "PeriodID"
' constants for the field to display from the unit set
' note that this can be the same as the primary key
' but can be another field as well (as in the default)
Const cUnitDisplayFld As String = "Unit"
' constants for the data type of the PK fields
' DesGrid only supports single field primary keys
' of Number or Text data types. If your primary
' key fields are text fields, use the value "String",
' otherwise leave them as "Numeric".
Const cUnitPKDataType As String = "Numeric"
Const cPeriodPKDataType As String = "Numeric"
' constants for the names of the date fields used
' in the period table. These must be of data type
' Date/Time and there must be two of them:
' one for the FromDate (starting date) and
' one for the ThruDate (ending date)
Const cFromFld As String = "FromDate"
Const cThruFld As String = "ThruDate"
Const cColorKeyFld As String = "ColorKey"
' constant for the name of the color key table
Const cColorTbl As String = "trefColorKey"
' variables to hold selected dates and units
Dim mdSelFrom As Date
Dim mdSelThru As Date
Dim mcolSelUnits As New Collection
' array for currently displayed dates
Dim madDisplay(1 To 32) As Date
' constant for special effect for selected image boxes
Const dsRaised As Long = 1
Const dsSunken As Long = 2
Const dsEtched As Long = 3
' stores true if the grid is clear
' we check this before running code to
' clear the grid (speeds scrolling)
Dim mfGridClear As Boolean
' width (in twips) of a day toggle
Const cHourW As Integer = 288
' number of image boxes in a row
Const cNumImgPerRow As Integer = 32
' dummy value for date variables
Const cBlankDate As Date = #1/1/100#
' variable to store state of selected grid boxes
Dim mfSelectedGrid As Boolean
Private Sub Form_Load()
Dim dOpen As Date
' initialize
mdSelFrom = cBlankDate
mdSelThru = cBlankDate
mfSelectedGrid = False
' fill the recordsets
LoadData
' format calendar portion of the form
' if a date was passed in OpenArgs, use that, else use Date
If Not IsDate(OpenArgs) Then
dOpen = DateSerial(Year(Date), Month(Date), Day(Date)) + TimeSerial(Hour(Time), 0, 0)
SetupCal dOpen
Else
dOpen = CDate(OpenArgs)
dOpen = DateSerial(Year(dOpen), Month(dOpen), Day(dOpen)) + TimeSerial(Hour(dOpen), 0, 0)
SetupCal dOpen
End If
' format unit list portion of the form
FillUnits mrsU.Fields(cUnitPK)
' you might want to clear the grid instead
' depending on how you want the form to initialize
DrawGrid
' set up the color key from table data
GetColorKeyCaptions
End Sub
Public Function DrawGrid() As Boolean
' puts colored diamonds and arrows on the grid
' according to data in the period recordset
On Error GoTo ErrLine
Dim sqlU As String
Dim x As Integer, iCol As Integer
Dim Y As Integer, sColor As String
Dim iImgFirst As Integer, iImgLast As Integer
Dim sUnitID As String
Dim fFromOff As Boolean, fThruOff As Boolean
Dim iFirstInRow As Integer, iTimeUnit As Integer
Dim tgl As ToggleButton
' open a recordset of periods in the current date range
sqlU = "SELECT " & cUnitPK & ", " & cColorKeyFld & ", " & _
cFromFld & ", " & cThruFld & " FROM " & cPeriodRS & _
" WHERE (" & cFromFld & " <= #" & madDisplay(cNumImgPerRow) & "# " & _
"AND " & cThruFld & " >= #" & madDisplay(1) & "# " & _
"AND (" & EnumUnits & ")) " & _
"ORDER BY " & cUnitPK
Set mrsP = mdbT.OpenRecordset(sqlU)
With mrsP
' exit if no records
If (.BOF And .EOF) Then
On Error Resume Next
.Close
Set mrsP = Nothing
ClearGrid
DisplayGrid True
DisplaySelectedGrid
GoTo ExitLine
End If
' work through the records, drawing arrows/diamonds on the appropriate row
ClearGrid
.MoveFirst
Do Until .EOF ' if no period for this unit, on to next unit toggle
' find the row number that matches the current record
For x = 1 To 10
Set tgl = Me.Controls("tglUnit" & Format(x, "00"))
If tgl.Tag = .Fields(cUnitPK) Then
Exit For
End If
Next x
' check to see if the from/thru dates are off screen
fFromOff = (.Fields(cFromFld) < madDisplay(1))
fThruOff = (.Fields(cThruFld) > madDisplay(cNumImgPerRow) + 1)
' Determine which image box represents our first date
iFirstInRow = ((x - 1) * cNumImgPerRow) + 1
If fFromOff Then
iTimeUnit = 0
Else
Select Case grpHour
Case 1
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cFromFld)) / 60
Case 2
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cFromFld)) / 30
Case 3
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cFromFld)) / 15
End Select
End If
iImgFirst = iFirstInRow + iTimeUnit
' determine which image box represents our last date
If .Fields(cThruFld) > madDisplay(cNumImgPerRow) Then
iImgLast = x * cNumImgPerRow
Else
Select Case grpHour
Case 1
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cThruFld)) / 60
Case 2
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cThruFld)) / 30
Case 3
iTimeUnit = DateDiff("n", madDisplay(1), .Fields(cThruFld)) / 15
End Select
' remove the '- 1' from the following line if you want the arrow to
' go through the ending time field
iImgLast = iFirstInRow + (iTimeUnit - 1)
End If
' draw the appropriate symbol
sColor = .Fields(cColorKeyFld)
If iImgFirst >= iImgLast Then
' one-unit period, so use a diamond
SetPic iImgFirst, sColor, "D"
Else
' multi-day period, so line w/arrows
If fFromOff Then
SetPic iImgFirst, sColor, "B"
Else
SetPic iImgFirst, sColor, "L"
End If
If fThruOff Then
If (.Fields(cFromFld) = madDisplay(cNumImgPerRow)) Then
SetPic iImgLast, sColor, "L"
Else
SetPic iImgLast, sColor, "B"
End If
Else
SetPic iImgLast, sColor, "R"
End If
' now the bar in between the end points
For Y = (iImgFirst + 1) To (iImgLast - 1)
SetPic Y, sColor, "B"
Next Y
End If
.MoveNext
Loop
End With
DisplayGrid True
mfGridClear = False
DisplaySelectedGrid
DrawGrid = True
ExitLine:
Exit Function
ErrLine:
DrawGrid = False
Resume ExitLine
End Function
Private Function DisplaySelectedGrid() As Boolean
' Sets the special effect of selected grid image boxes
' to dsSunken. Note that this function is cosmetic, since
' there may be selected units not diplayed.
' Returns True if successful, false on error
On Error GoTo ErrLine
Dim iReturn As Integer
' loop counters
Dim iUnitTgl As Integer, x As Integer
' unit toggle, image box
Dim tglU As ToggleButton, imgX As Image
' image box numbers
Dim iFstImg As Integer, iLstImg As Integer
' booleans to determine displayability of arrows
Dim fFirstOff As Boolean, fLastOff As Boolean
Dim fBigWide As Boolean ' a range that spans beyond both sides of the grid
Dim iInterval As Integer
' make sure none are sunken
If mfSelectedGrid Then
For x = 1 To 320
Set imgX = Me.Controls("img" & Format(x, "000"))
imgX.SpecialEffect = dsEtched
Next x
End If
' if no date is selected or no units selected, exit
If ((mdSelFrom = cBlankDate) Or (mcolSelUnits.Count = 0)) Then
iReturn = 0
mfSelectedGrid = False
GoTo ExitLine
Else
mfSelectedGrid = True
End If
' check if the from/thru dates are off screen
' fFirstOff is True if the first selected date has been scrolled off screen
fFirstOff = ((mdSelFrom < madDisplay(1)) Or _
(mdSelFrom > madDisplay(cNumImgPerRow)))
' fLastOff is True if the last selected date has been scrolled off screen
fLastOff = ((mdSelThru > madDisplay(cNumImgPerRow) + 1) Or _
((mdSelThru <= madDisplay(1)) And _
(mdSelThru <> cBlankDate)))
' fBigWide is True if both the first and last dates are off screen (so just a big wide bar)
fBigWide = (mdSelFrom < madDisplay(1) And mdSelThru > madDisplay(cNumImgPerRow))
If (fFirstOff And fLastOff) And Not fBigWide Then
' don't draw an arrow
Else
' loop through the unit toggles, looking for selected ones
For iUnitTgl = 1 To 10
Set tglU = Me.Controls("tglUnit" & Format$(iUnitTgl, "00"))
If tglU Then
' here we figure out the first and last image boxes
Select Case grpHour
Case 1: iInterval = 60
Case 2: iInterval = 30
Case 3: iInterval = 15
End Select
' clean the date values
mdSelThru = DateSerial(Year(mdSelThru), Month(mdSelThru), Day(mdSelThru)) + _
TimeSerial(Hour(mdSelThru), Minute(mdSelThru), 0)
mdSelFrom = DateSerial(Year(mdSelFrom), Month(mdSelFrom), Day(mdSelFrom)) + _
TimeSerial(Hour(mdSelFrom), Minute(mdSelFrom), 0)
If mdSelThru <= DateAdd("n", iInterval, mdSelFrom) Then
' diamond
iFstImg = ((iUnitTgl - 1) * cNumImgPerRow) + ToggleNumFromDate(mdSelFrom)
Set imgX = Me.Controls("img" & Format(iFstImg, "000"))
imgX.SpecialEffect = dsSunken
Else
' arrow
If fFirstOff Then
iFstImg = ((iUnitTgl - 1) * cNumImgPerRow) + 1
Else
iFstImg = ((iUnitTgl - 1) * cNumImgPerRow) + ToggleNumFromDate(mdSelFrom)
End If
If fLastOff Then
iLstImg = iUnitTgl * cNumImgPerRow
Else
iLstImg = ((iUnitTgl - 1) * cNumImgPerRow) + ToggleNumFromDate(mdSelThru)
End If
iLstImg = iLstImg - 1
For x = iFstImg To iLstImg
Set imgX = Me.Controls("img" & Format(x, "000"))
imgX.SpecialEffect = dsSunken
Next x
End If
End If
Next iUnitTgl
End If
mfGridClear = False
DisplaySelectedGrid = True
ExitLine:
Exit Function
ErrLine:
DisplaySelectedGrid = False
Resume ExitLine
End Function
