Results 1 to 2 of 2
  1. #1
    philben is offline Novice
    Windows 7 64bit Access 2010 32bit
    Join Date
    Jan 2011
    Posts
    1

    How to add sparklines on an Access report

    Because a graphics is more explicit than numbers...

    Screenshot:


    Module source code
    Code:
    Option Compare Database
    Option Explicit
    '------------------------------------------------------------------------------------------------------------------
    'Object : How to add sparklines on an Access report
    ' -> SparkLine, SparkBars, SparkOnOff
    'Date : 29/01/2011
    'Author : Philben (based on an idea of E. Tufte - http://en.wikipedia.org/wiki/Sparkline)
    'Version: 1.0
    'Call : On the SectionName_Format event in the report
    '-------------------------------------------------------------------------------------------------------------------
    'Constants for the SparkLine function
    Private Const clLineColor As Long = vbBlue   'Line color
    Private Const clMinPointColor As Long = vbRed   'Min point color
    Private Const clMaxPointColor As Long = vbGreen   'Max point color
    Private Const clPointRadius As Long = 15   'Radius of the point (in twips)
    'Constants for SparkBars
    Private Const clBarColor As Long = vbBlue   'Bar color
    Private Const clMinBarColor As Long = vbRed   'Min color
    Private Const clMaxBarColor As Long = vbGreen   'Max color
    'Constants for SparkOnOff
    Private Const clOnBarColor As Long = vbBlue   'Color of positives bars
    Private Const clOffBarColor As Long = vbRed   'Color of negatives bars
    Private Const clPivotBarColor As Long = vbBlack   'Color of the pivot value
    Private Const clPivotHeight As Long = 10   'Height of the pivot (in twips)
    'To draw a line graph
    'Parameters :
    ' - Reference of the label control to define the position and the dimensions of the sparkbars
    ' - The list of values
    Public Sub SparkLine(ByRef oSL As Access.Label, ParamArray aValues() As Variant)
       Const clNone As Long = -1
       Dim oRpt As Access.Report
       Dim vMin As Variant, vMax As Variant
       Dim i As Long, lUpper As Long, X As Long, Y As Long, lTmpY As Long, lLastY As Long
       Dim lSpaceWidth As Long, lCountSpace As Long
       Dim fCst As Single
       lUpper = UBound(aValues)
       For i = 0 To lUpper
          If Not IsNull(aValues(i)) Then
             If Not IsEmpty(vMax) Then
                If aValues(i) > vMax Then vMax = aValues(i)
             Else
                vMax = aValues(i)
             End If
             If Not IsEmpty(vMin) Then
                If aValues(i) < vMin Then vMin = aValues(i)
             Else
                vMin = aValues(i)
             End If
          End If
       Next i
       If Not IsEmpty(vMin) Then
          With oSL
             lSpaceWidth = (.Width - 2 * clPointRadius) / lUpper
             X = .Left + clPointRadius
             fCst = CSng((.Height - 2 * clPointRadius))
             If vMax <> vMin Then
                fCst = CSng(fCst / (vMax - vMin))
             End If
             Y = .Top + .Height
          End With
          Set oRpt = oSL.Parent
          If IsNull(aValues(0)) Then
             lLastY = clNone
          Else
             lLastY = CLng(Y - (aValues(0) - vMin) * fCst - clPointRadius)
          End If
          lCountSpace = 1
          For i = 1 To lUpper
             If Not IsNull(aValues(i)) Then
                lTmpY = CLng(Y - (aValues(i) - vMin) * fCst - clPointRadius)
                If lLastY <> clNone Then
                   oRpt.Line (X, lLastY)-(X + lSpaceWidth * lCountSpace, lTmpY), clLineColor
                   SparkLinePoint oRpt, X, lLastY, aValues(i - lCountSpace), vMin, vMax
                End If
                X = X + lSpaceWidth * lCountSpace
                lLastY = lTmpY
                lCountSpace = 1
             Else
                lCountSpace = lCountSpace + 1
             End If
          Next i
          If lLastY <> clNone Then SparkLinePoint oRpt, X, lLastY, aValues(i - lCountSpace), vMin, vMax
       End If
    End Sub
    'To draw a bars graph
    'Parameters :
    ' - Reference of the label control to define the position and the dimensions of the sparkbars
    ' - The list of values
    Public Sub SparkBars(ByRef oSL As Access.Label, ParamArray aValues() As Variant)
       Dim vMin As Variant, vMax As Variant, vMinR As Variant
       Dim i As Long, lUpper As Long, X As Long, Y As Long, Yr As Long
       Dim lBarWidth As Long, lSpaceWidth As Long, lColor As Long
       Dim fCst As Single
       lUpper = UBound(aValues)
       For i = 0 To lUpper
          If Not IsNull(aValues(i)) Then
             If Not IsEmpty(vMax) Then
                If aValues(i) > vMax Then vMax = aValues(i)
             Else
                vMax = aValues(i)
             End If
             If Not IsEmpty(vMin) Then
                If aValues(i) < vMin Then vMin = aValues(i)
             Else
                vMin = aValues(i)
             End If
          End If
       Next i
       If Not IsEmpty(vMin) Then
          Select Case vMin
             Case Is < vMax
                vMinR = vMin - ((vMax - vMin) / 10)
             Case Is <> 0
                vMinR = vMin - Sgn(vMin) * vMin / 10
             Case Else
                vMinR = 0.9
          End Select
          With oSL
             lBarWidth = CLng(.Width / (lUpper * 1.5 + 1))
             lSpaceWidth = CLng(lBarWidth / 2)
             X = .Left
             Yr = .Height
             Y = .Top + Yr
          End With
          fCst = CSng(Yr / (vMax - vMinR))
          For i = 0 To lUpper
             If Not IsNull(aValues(i)) Then
                Select Case aValues(i)
                   Case Is >= vMax
                      lColor = clMaxBarColor
                   Case Is <= vMin
                      lColor = clMinBarColor
                   Case Else
                      lColor = clBarColor
                End Select
                oSL.Parent.Line (X, Y)-(X + lBarWidth, CLng(Y - (aValues(i) - vMinR) * fCst)), lColor, BF
             End If
             X = X + lBarWidth + lSpaceWidth
          Next i
       End If
    End Sub
    'To Draw a On/Off graph
    'Parameters :
    ' - Reference of the label to define the position and the dimensions of the sparkbars
    ' - the pivot value
    ' - The list of values
    Public Sub SparkOnOff(ByRef oSL As Access.Label, ByVal vPivot As Variant, ParamArray aValues() As Variant)
       Dim i As Long, lUpper As Long, X As Long, Y1 As Long, Y2 As Long, lPivotTop As Long
       Dim lBarHeight As Long, lBarWidth As Long, lSpaceWidth As Long, lColor As Long
       vPivot = Nz(vPivot, 0)
       lUpper = UBound(aValues)
       With oSL
          lBarWidth = CLng(.Width / (lUpper * 1.5 + 1))
          lSpaceWidth = CLng(lBarWidth / 2)
          lBarHeight = CLng(.Height - clPivotHeight) / 2
          lPivotTop = .Top + lBarHeight + 1
          X = .Left
       End With
       For i = 0 To lUpper
          If Not IsNull(aValues(i)) Then
             Select Case aValues(i)
                Case Is > vPivot
                   Y1 = lPivotTop - 1
                   Y2 = Y1 - lBarHeight
                   lColor = clOnBarColor
                Case Is < vPivot
                   Y1 = lPivotTop + clPivotHeight + 1
                   Y2 = Y1 + lBarHeight
                   lColor = clOffBarColor
                Case Else
                   Y1 = lPivotTop
                   Y2 = Y1 + clPivotHeight
                   lColor = clPivotBarColor
             End Select
             oSL.Parent.Line (X, Y1)-(X + lBarWidth, Y2), lColor, BF
          End If
          X = X + lBarWidth + lSpaceWidth
       Next i
    End Sub
    'To Draw a circle for each point on the sparkline
    'Used by the SparkLine function
    Private Sub SparkLinePoint(ByRef oRpt As Access.Report, ByVal X As Long, ByVal Y As Long, ByVal vValue As Variant, _
                               ByVal vMin As Variant, ByVal vMax As Variant)
       Dim lPointColor As Long
       Select Case vValue
          Case Is >= vMax
             lPointColor = clMaxPointColor
          Case Is <= vMin
             lPointColor = clMinPointColor
          Case Else
             lPointColor = clLineColor
       End Select
       oRpt.FillStyle = 0
       oRpt.FillColor = lPointColor
       oRpt.Circle (X, Y), clPointRadius, lPointColor
    End Sub
    see examples attached (sparkline appears in the preview print mode only)

    Best regards,

    Philippe
    Last edited by RuralGuy; 01-30-2011 at 06:14 AM. Reason: Added Code Tags and formatted

  2. #2
    TheShabz is offline Court Jester
    Windows XP Access 2003
    Join Date
    Feb 2010
    Posts
    1,368
    Welcome to the boards. Best first post in a long long time.

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 4
    Last Post: 12-13-2010, 05:33 PM
  2. Replies: 2
    Last Post: 08-25-2010, 01:42 PM
  3. Access Report
    By jamil_kwi in forum Access
    Replies: 4
    Last Post: 05-30-2010, 06:56 AM
  4. Replies: 3
    Last Post: 05-21-2010, 03:57 PM
  5. PDF used in Access Report
    By jsh in forum Forms
    Replies: 2
    Last Post: 04-06-2009, 12:25 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums