P
PFMcCracken
What is wrong with the 'CHANGE COLOUR SECTION' below ?? Tracing through
the program shows it works, but the colours do not change.
----------------------
Public Function WhiteGray()
Dim Today As Integer
Dim NextDay As Integer
Dim DayRec As Integer
Dim WhatColour As Long
Dim OldColour As Long
Dim cnnConn As ADODB.Connection
Dim rstData As ADODB.Recordset
Dim fld As ADODB.Field
Dim strConn As String
Dim strSQL As String
Dim strDBPath As String
Dim StrQryName As String
Dim Reccnt As Integer
Dim Recnum As Integer
Dim IsNextDay As Boolean
strDBPath = "L:\SAMPLE.MRM"
StrQryName = "CAFC_MeetingSummary"
Recnum = 0
NextDay = 0
IsNextDay = False
' Open the connection.
Set cnnConn = New ADODB.Connection
With cnnConn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Open strDBPath
End With
' Open a recordset
Set rstData = New ADODB.Recordset
'With rstData
' Open the query by using a ----, read-only Recordset object.
rstData.Open Source:=StrQryName, _
ActiveConnection:=cnnConn, _
CursorType:=adOpenStatic, _
LockType:=adLockReadOnly
' Options:=adCmdTableDirect
If Not rstData.BOF Then
rstData.MoveFirst
' rstData.MoveNext
End If
'Record Total Number of Records
Reccnt = rstData.RecordCount
'Record the Record Counter, Initial Value
Recnum = rstData.AbsolutePosition
'Grab the initial value as a starting reference
OldColour = Reports!CAFC_MeetingSummary.Detail.BackColor
'Reports!CAFC_MeetingSummary.[Meeting Start].BackStyle = "Transparent"
' Display the records in the Debug window.
Do While Not rstData.EOF And (Recnum < (Reccnt - 1))
For Each fld In rstData.Fields
Debug.Print fld.Value & ";";
Next
'Record the Record Counter, Current Value
Recnum = rstData.AbsolutePosition
' FIX (Recnum < (Reccnt - 1)) *************
' Today = Day(Reports!CAFC_MeetingSummary![Meeting Start])
Today = Day(rstData("Meeting Start"))
'Advance the record pointer
rstData.MoveNext
'FOR DEBUGGING Recnum = rstData.AbsolutePosition
'NextDay= Day(Reports!CAFC_MeetingSummary![Meeting Start])
NextDay = Day(rstData("Meeting Start"))
'Return the record pointer to the correct record
rstData.MovePrevious
' Get the current colour
WhatColour = Reports!CAFC_MeetingSummary.Detail.BackColor
' CHANGE COLOUR SECTION
If (Today = DayRec) And (Today <> NextDay) Then
If WhatColour = vbWhite Then
OldColour = Reports!CAFC_MeetingSummary.Detail.BackColor
'Gray Colour
Reports!CAFC_MeetingSummary.Detail.BackColor = 12632256
Reports!CAFC_MeetingSummary.[Meeting Start].BackColor = 12632256
Else
' End If
' If WhatColour <> vbWhite Then
OldColour = Reports!CAFC_MeetingSummary.Detail.BackColor
Reports!CAFC_MeetingSummary.Detail.BackColor = vbWhite
Reports!CAFC_MeetingSummary.[Meeting Start].BackColor = vbWhite
End If
End If
'Pass Next Day Confirmation Value
If (Today <> NextDay) Then
DayRec = NextDay
End If
Debug.Print
rstData.MoveNext
Loop
'End the Recordset Loop
'Close the Recordset object.
rstData.Close
'End With
' Close connection and destroy object variables.
cnnConn.Close
Set rstData = Nothing
Set cnnConn = Nothing
End Function
the program shows it works, but the colours do not change.
----------------------
Public Function WhiteGray()
Dim Today As Integer
Dim NextDay As Integer
Dim DayRec As Integer
Dim WhatColour As Long
Dim OldColour As Long
Dim cnnConn As ADODB.Connection
Dim rstData As ADODB.Recordset
Dim fld As ADODB.Field
Dim strConn As String
Dim strSQL As String
Dim strDBPath As String
Dim StrQryName As String
Dim Reccnt As Integer
Dim Recnum As Integer
Dim IsNextDay As Boolean
strDBPath = "L:\SAMPLE.MRM"
StrQryName = "CAFC_MeetingSummary"
Recnum = 0
NextDay = 0
IsNextDay = False
' Open the connection.
Set cnnConn = New ADODB.Connection
With cnnConn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Open strDBPath
End With
' Open a recordset
Set rstData = New ADODB.Recordset
'With rstData
' Open the query by using a ----, read-only Recordset object.
rstData.Open Source:=StrQryName, _
ActiveConnection:=cnnConn, _
CursorType:=adOpenStatic, _
LockType:=adLockReadOnly
' Options:=adCmdTableDirect
If Not rstData.BOF Then
rstData.MoveFirst
' rstData.MoveNext
End If
'Record Total Number of Records
Reccnt = rstData.RecordCount
'Record the Record Counter, Initial Value
Recnum = rstData.AbsolutePosition
'Grab the initial value as a starting reference
OldColour = Reports!CAFC_MeetingSummary.Detail.BackColor
'Reports!CAFC_MeetingSummary.[Meeting Start].BackStyle = "Transparent"
' Display the records in the Debug window.
Do While Not rstData.EOF And (Recnum < (Reccnt - 1))
For Each fld In rstData.Fields
Debug.Print fld.Value & ";";
Next
'Record the Record Counter, Current Value
Recnum = rstData.AbsolutePosition
' FIX (Recnum < (Reccnt - 1)) *************
' Today = Day(Reports!CAFC_MeetingSummary![Meeting Start])
Today = Day(rstData("Meeting Start"))
'Advance the record pointer
rstData.MoveNext
'FOR DEBUGGING Recnum = rstData.AbsolutePosition
'NextDay= Day(Reports!CAFC_MeetingSummary![Meeting Start])
NextDay = Day(rstData("Meeting Start"))
'Return the record pointer to the correct record
rstData.MovePrevious
' Get the current colour
WhatColour = Reports!CAFC_MeetingSummary.Detail.BackColor
' CHANGE COLOUR SECTION
If (Today = DayRec) And (Today <> NextDay) Then
If WhatColour = vbWhite Then
OldColour = Reports!CAFC_MeetingSummary.Detail.BackColor
'Gray Colour
Reports!CAFC_MeetingSummary.Detail.BackColor = 12632256
Reports!CAFC_MeetingSummary.[Meeting Start].BackColor = 12632256
Else
' End If
' If WhatColour <> vbWhite Then
OldColour = Reports!CAFC_MeetingSummary.Detail.BackColor
Reports!CAFC_MeetingSummary.Detail.BackColor = vbWhite
Reports!CAFC_MeetingSummary.[Meeting Start].BackColor = vbWhite
End If
End If
'Pass Next Day Confirmation Value
If (Today <> NextDay) Then
DayRec = NextDay
End If
Debug.Print
rstData.MoveNext
Loop
'End the Recordset Loop
'Close the Recordset object.
rstData.Close
'End With
' Close connection and destroy object variables.
cnnConn.Close
Set rstData = Nothing
Set cnnConn = Nothing
End Function