I am using Access 2007 and I found that Access 2010 provides data bars as a conditional formatting option. I found the following code for applying data bars.
I am attempting to apply the data bar against a control in a continuous report, but it is not working. The code does not error, but my label formats do not change.
The function found online. I added two labels (baselbl and lblMeter) to my report:
My calling code:
Thank you for the help.
I am attempting to apply the data bar against a control in a continuous report, but it is not working. The code does not error, but my label formats do not change.
The function found online. I added two labels (baselbl and lblMeter) to my report:
Code:
Public Function PctMeter(vAmt As Variant, vTotal As Variant)
Dim sngPct As Single
On Error GoTo PctMeter_Error
sngPct = vAmt / vTotal
If sngPct <= 1 Then
Me!baselbl.Caption = Int(sngPct * 100) & "%"
Me!lblMeter.Width = CLng(Me!baselbl.Width * sngPct)
Else
Me!baselbl.Caption = "Greater than 100% - Check your amounts"
Me!lblMeter.Width = CLng(Me!baselbl.Width * 1)
End If
Me!lblMeter.BackColor = 16711680
Select Case sngPct 'change the caption font color to white if greater than 50%
Case Is < 0.5
Me!baselbl.ForeColor = 0
Case Else
Me!baselbl.ForeColor = 16777215
End Select
Me.Repaint
PctMeter_Exit:
Exit Function
PctMeter_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PctMeter of VBA Document Form_frmProgressBar"
Resume PctMeter_Exit
End Function
My calling code:
Private Sub Report_Load()
On Error GoTo Err_Report
Dim MyvAmt As Variant
Dim MyvTotal As Variant
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("qryPROJECTExpenditureForecastTABLE", dbOpenDynaset)
MyvTotal = DSum("[fldABSVarianceMONTH]", "qryPROJECTExpenditureForecastTABLE")
If Not (rs.BOF And rs.EOF) Then
If rs.RecordCount <> 0 Then
Do While Not rs.EOF
If rs![fldABSVarianceMONTH] <> Something Then
Exit Do
End If
MyvAmt = rs![fldABSVarianceMONTH]
Call PctMeter(MyvAmt, MyvTotal)
rs.MoveNext
Loop
End If
End If
rs.Close
Exit_Report:
Set rs = Nothing
Set db = Nothing
Exit Sub
Err_Report:
Resume Exit_Report
End Sub
Thank you for the help.