What is wrong with the colour change logic for this report ??

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
 
D

Darren

Just in case you want to play with a simpler method for shading alternate
lines on a report, try this:

In the reports module header declare a boolean variable:

Private mbShade AS Boolean

In your reports DETAIL section, write the following OnFormat code:

Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Const lSHADED As Long = 13290186
If mbShade = TRUE Then
Me.Section(acDetail).BackColor = lSHADED
Else
Me.Section(acDetail).BackColor = vbWhite
End If
mbShade = Not mbShade
End Sub

This will alternate the gray shading when each detail section has a new
record to display.

PFMcCracken said:
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
Click to expand...
 
P

PFMcCracken

Thanks. I'll try that. But the logic surrounding the background colour

change seems to be working but do not display changes.

Philip


Darren said:
Just in case you want to play with a simpler method for shading alternate
lines on a report, try this:

In the reports module header declare a boolean variable:

Private mbShade AS Boolean

In your reports DETAIL section, write the following OnFormat code:

Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Const lSHADED As Long = 13290186
If mbShade = TRUE Then
Me.Section(acDetail).BackColor = lSHADED
Else
Me.Section(acDetail).BackColor = vbWhite
End If
mbShade = Not mbShade
End Sub

This will alternate the gray shading when each detail section has a new
record to display.

PFMcCracken said:
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
Click to expand...
Click to expand...
 

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

What is wrong with the colour change code ?? 0
What the H#!! is wrong with this? 9
Want to merge access with word; what is wrong with this code? 2

Top