Sparklines: satisfaction and disappointment

Could go into a whole diatribe about the paradoxical human condition of conflicting feelings but will keep it simple. Have achieved what I set out to do: and -- sparkline the bank's account opening activity during a given period. Well, have achieved it roughly, anyway. But generating sparklines is a big hassle: code for Office 2000 or XP and above? (2000 doesn't have a feature which makes the user's life a hell of a lot easier.) When generating multiple sparklines at the same time, scale them all to the same scale or different (as they are above)? Currently I'm coding for MSO2000, though there's no guarantee the code will actually work; and scaling to different scales even when generating in the same batch. Will have to change both these settings because the alternatives are so much more helpful.

On the plus side, wrote a clever little toolbar that manages generated sparklines -- i.e. selecting and deleting them -- almost well enough to be called a sparkline manager.

Here are the macros that pull in and parse the plain-text reports generated daily by the bank's software:

Sub inputData(fname, aDoc)
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set fin = fso.OpenTextFile(fname, 1)
  branchNamesStore = ""
  openingCountsStore = ""
  printingCounts = False
  weHaveTabs = False

  Do While fin.AtEndOfStream <> True
      aLine = fin.ReadLine
   
      Dim branchNamePoses(5)
      branchNamePoses(0) = InStr(1, aLine, " BRANCH       ")
      branchNamePoses(1) = InStr(1, aLine, " BRANCH" + vbTab)
      branchNamePoses(2) = InStr(1, aLine, " BRAN       ")
      branchNamePoses(3) = InStr(1, aLine, " BRAN" + vbTab)
      branchNamePoses(4) = InStr(1, aLine, " BRANC      ")
      branchNamePoses(5) = InStr(1, aLine, " BRANC" + vbTab)
   
      numAcctsPos = InStr(1, aLine, "OPENED :")
      lineHasComma = InStr(1, aLine, ",")
      branchName = ""
      branchNameTemp = ""
      numAcctsStr = ""

      For posCounter = 0 To UBound(branchNamePoses)
          If branchNamePoses(posCounter) <> 0 And lineHasComma = 0 Then
              If posCounter Mod 2 = 0 Then ' No tabs in this file
                  i = branchNamePoses(posCounter) - 1
                  Do While Mid(aLine, i, 1) <> " "
                      branchName = branchName & Mid(aLine, i, 1)
                      i = i - 1
                  Loop
                  branchNameTemp = branchName
                  branchName = StrReverse(branchNameTemp)
                  branchNamesStore = branchNamesStore & " " & branchName
              Else ' Tabs in the file
                  weHaveTabs = True
                  i = branchNamePoses(posCounter) - 1
                  Do While Mid(aLine, i, 1) <> vbTab
                      branchName = branchName & Mid(aLine, i, 1)
                      i = i - 1
                  Loop
                  branchNameTemp = branchName
                  branchName = StrReverse(branchNameTemp)
                  branchNamesStore = branchNamesStore & " " & branchName
              End If
          ElseIf InStr(1, aLine, "HEAD OFFICE") And lineHasComma = 0 And Not InStr(1, branchNamesStore, "HEADOFFICE") Then
              branchNamesStore = branchNamesStore & " HEADOFFICE"
              Exit For
          End If
      Next posCounter
   
      If numAcctsPos <> 0 Then
          i = numAcctsPos + 9
          Do While i < Len(aLine) + 1
              curChar = Mid(aLine, i, 1)
              If weHaveTabs Then
                  If curChar <> vbTab Then numAcctsStr = numAcctsStr & curChar
              Else
                  If curChar <> " " Then
                      numAcctsStr = numAcctsStr & curChar
                  Else
                      If Len(numAcctsStr) >= 2 Then Exit Do
                  End If
              End If
              i = i + 1
          Loop
          openingCountsStore = openingCountsStore & " " & numAcctsStr
      End If
  Loop
  fin.Close

  branchNames = Strings.Split(Trim(branchNamesStore))
  openingCounts = Strings.Split(Trim(openingCountsStore))
  Debug.Assert UBound(branchNames) = UBound(openingCounts)

  For Each par In aDoc.Paragraphs
      docLine = Mid(par.Range.Text, 1, Len(par.Range.Text) - 1)
      If docLine = "\begin{acc_opening_counts}" Then
          printingCounts = True
          GoTo nextItem
      ElseIf docLine = "\end{acc_opening_counts}" Then
          printingCounts = False
          GoTo nextItem
      End If
   
      typedNumber = False
      If printingCounts Then
          curBranch = Trim(par.Range.Words.First)
          par.Range.Select
          Selection.EndKey Unit:=wdLine
          For i = 0 To UBound(branchNames)
              If branchNames(i) = curBranch Then
                  typedNumber = True
                  Selection.TypeText Text:=" " & openingCounts(i)
                  GoTo nextItem
              End If
          Next i
          If typedNumber = False Then Selection.TypeText Text:=" 0"
      End If
nextItem:
  Next
End Sub

Sub importStats()
  Dim theDoc As Document
  Set theDoc = ActiveDocument

  Set fso = CreateObject("Scripting.FileSystemObject")
  monthFolder = "\\accounts\MB_REPORT 2004\YEAR2004\DECEMBER2004\"

  For i = 1 To 31
      If i < 10 Then
          fname = monthFolder + "Dhanmondi Branch  2004-12-0" & Str(i) & "\AC_OPEN_ALL"
          fname = Strings.Replace(fname, "0 ", "0")
          If fso.FileExists(fname) Then
              inputData fname, theDoc
          Else
              Debug.Print fname, "does not exist"
          End If
      Else
          fname = monthFolder + "Dhanmondi Branch  2004-12-" & i & "\AC_OPEN_ALL"
          If fso.FileExists(fname) Then
              inputData fname, theDoc
          Else
              Debug.Print fname, "does not exist"
          End If
      End If
  Next i
End Sub

May not look like much but was a bitch to write thanks to the lack of regular expressions in vanilla Office VBA. This was the first half. The second half was even harder because even more ill-defined -- almost no one's ever done it before.

The sparkline generator:
Microsoft Word Object ThisDocument

Private Sub Document_Close()
  myDocumentClose
End Sub

Private Sub Document_Open()
  myDocumentOpen
End Sub

Module NewMacros

Function sizeof(arr)
  sizeof = UBound(arr) - LBound(arr)
End Function

Function sort(arr As Variant, Optional SortAscending As Boolean = True)
  ' Chris Rae's VBA Code Archive - http://chrisrae.com/vba
  ' By Chris Rae, 19/5/99. My thanks to
  ' Will Rickards and Roemer Lievaart
  ' for some fixes.
  ToSort = arr
  Dim AnyChanges As Boolean
  Dim BubbleSort As Long
  Dim SwapFH As Variant
  Do
      AnyChanges = False
      For BubbleSort = LBound(ToSort) To UBound(ToSort) - 1
          If (ToSort(BubbleSort) > ToSort(BubbleSort + 1) And SortAscending) _
             Or (ToSort(BubbleSort) < ToSort(BubbleSort + 1) And Not SortAscending) Then
              ' These two need to be swapped
              SwapFH = ToSort(BubbleSort)
              ToSort(BubbleSort) = ToSort(BubbleSort + 1)
              ToSort(BubbleSort + 1) = SwapFH
              AnyChanges = True
          End If
      Next BubbleSort
  Loop Until Not AnyChanges
  sort = ToSort
End Function

Function arrayMin(theArr)
  Dim arr()
  ReDim arr(UBound(theArr))

  For i = LBound(theArr) To UBound(theArr)
      arr(i) = Val(theArr(i))
  Next i

  If sizeof(arr) = 1 Then
      arrayMin = arr(LBound(arr))
  ElseIf sizeof(arr) = 2 Then
      If arr(LBound(arr)) < arr(UBound(arr)) Then
          smaller = arr(LBound(arr))
      ElseIf arr(UBound(arr)) < arr(LBound(arr)) Then
          smaller = arr(UBound(arr))
      End If
      arrayMin = smaller
  Else
      sortedArr = sort(arr)
      arrayMin = sortedArr(LBound(sortedArr))
  End If
End Function

Function arrayMax(theArr)
  Dim arr()
  ReDim arr(UBound(theArr))

  For i = LBound(theArr) To UBound(theArr)
      arr(i) = Val(theArr(i))
  Next i

  If sizeof(arr) = 1 Then
      arrayMax = arr(LBound(arr))
  ElseIf sizeof(arr) = 2 Then
      If arr(LBound(arr)) < arr(UBound(arr)) Then
          bigger = arr(UBound(arr))
      ElseIf arr(UBound(arr)) < arr(LBound(arr)) Then
          bigger = arr(LBound(arr))
      End If
      arrayMax = bigger
  Else
      sortedArr = sort(arr)
      arrayMax = sortedArr(UBound(sortedArr))
  End If
End Function

Function scaleHeight(num, max, theHeight) As Double
  If max = 0 Then
      scaleHeight = 0
  Else
      scaleHeight = theHeight - (num / max) * theHeight
  End If
End Function

Function lineChart(aLine, theHeight, widthMul, showAvg, vertPos As Single, ByRef header, Optional ByVal scaleSame As Boolean, Optional scaleMax, Optional scaleMin)
  If Right(aLine, 1) = vbCr Then
      theLine = Left(aLine, Len(aLine) - 1)
  Else
      theLine = aLine
  End If
  theSeries = Split(theLine) ' Contains the header label
  Dim numSeries() ' Does not hold the label

  numNils = 0
  For counter = 1 To UBound(theSeries)
      If theSeries(counter) = "nil" Then numNils = numNils + 1
  Next counter

  ReDim numSeries(UBound(theSeries) - numNils - 1)
  For i = numNils + 1 To UBound(theSeries)
      numSeries(i - numNils - 1) = Val(theSeries(i))
  Next i

  If scaleSame Then
      min = scaleMin
      tempMax = scaleMax
  Else
      min = arrayMin(numSeries)
      tempMax = arrayMax(numSeries)
  End If
  max = tempMax - min

  For i = 0 To UBound(numSeries)
      tempNum = numSeries(i) - min
      numSeries(i) = tempNum
  Next

  If showAvg Then
      sum = 0
      For Each elem In numSeries
          sum = sum + elem
      Next
      avg = sum / UBound(numSeries)
      avgHeight = scaleHeight(avg, max, theHeight)
  End If

  With ActiveDocument.shapes.BuildFreeform(msoEditingAuto, (numNils * widthMul) + 100, scaleHeight(numSeries(0), max, theHeight) + vertPos)
      For i = 1 To UBound(numSeries)
          .AddNodes msoSegmentLine, msoEditingAuto, ((numNils + i) * widthMul) + 100, scaleHeight(numSeries(i), max, theHeight) + vertPos
      Next i
      freeformName = .ConvertToShape.Name
  End With
   
  With ActiveDocument.shapes.AddShape(msoShapeOval, (numNils + i - 1) * widthMul - 2 + 100, scaleHeight(numSeries(i - 1), max, theHeight) + vertPos - 2, 4, 4)
      .Fill.Visible = msoTrue
      .Fill.Solid
      .Fill.ForeColor.RGB = RGB(51, 102, 255)
      .Line.ForeColor.RGB = RGB(51, 102, 255)
      dotName = .Name
  End With
   
  With ActiveDocument.shapes.AddTextbox(msoTextOrientationHorizontal, (numNils + i - 1) * widthMul + 5 + 100, scaleHeight(numSeries(i - 1), max, theHeight) + vertPos - 7.5, 50, 15)
      .TextFrame.TextRange.Text = strings.Trim(Str(numSeries(i - 1) + min))
      .TextFrame.TextRange.Font.Size = 8
      .TextFrame.TextRange.Font.Color = RGB(51, 102, 255)
      .Fill.ForeColor.RGB = RGB(255, 255, 255)
      .Line.Visible = False
      .Fill.Transparency = 1#
      textBoxName = .Name
  End With

  If showAvg Then
      With ActiveDocument.shapes.AddLine(numNils * widthMul + 100, avgHeight + vertPos, (numNils + i - 1) * widthMul + 100, avgHeight + vertPos)
          .Line.ForeColor.RGB = RGB(153, 51, 0)
          .Line.DashStyle = msoLineRoundDot
          avgLineName = .Name
      End With
  End If

  header = theSeries(0)
  If showAvg Then
      retval = Array(freeformName, dotName, textBoxName, avgLineName)
  Else
      retval = Array(freeformName, dotName, textBoxName)
  End If

  For Each elem In retval
      Debug.Print elem
  Next
  lineChart = retval
End Function

Sub selectChart()
  Dim ctl As CommandBarComboBox
  Set ctl = CommandBars("Sparklines").Controls(2)
  If ctl.ListCount < 1 Then Exit Sub

  lineArr = Split(ctl.List(ctl.ListIndex), ":")

  theNames = Split(Trim(lineArr(1)), ",")
  Dim shapeNames() As Variant
  ReDim shapeNames(UBound(theNames))
  For i = 0 To UBound(shapeNames)
      shapeNames(i) = theNames(i)
  Next i

  ActiveDocument.shapes.Range(shapeNames).Select
End Sub

Sub deleteChart()
  Dim ctl As CommandBarComboBox
  Set ctl = CommandBars("Sparklines").Controls(2)
  If ctl.ListCount < 1 Then Exit Sub

  selectChart
  Selection.Delete
  ctl.RemoveItem ctl.ListIndex
End Sub

Sub moveChartRight()
  Dim ctl As CommandBarComboBox
  Set ctl = CommandBars("Sparklines").Controls(2)
  If ctl.ListCount < 1 Then Exit Sub

  selectChart
  Selection.MoveRight
End Sub

Sub moveChartLeft()
  Dim ctl As CommandBarComboBox
  Set ctl = CommandBars("Sparklines").Controls(2)
  If ctl.ListCount < 1 Then Exit Sub

  selectChart
  Selection.MoveLeft
End Sub

Sub refresh()
  myDocumentClose
  myDocumentOpen
End Sub

Sub myDocumentOpen()
  CommandBars.Add(Name:="Sparklines", Temporary:=False).Visible = True

  With CommandBars("Sparklines")
      With .Controls.Add(Type:=msoControlButton, Temporary:=False)
          .Caption = "Line Chart..."
          .Style = msoButtonCaption
          .OnAction = "lineChartGui"
      End With
      .Controls.Add Type:=msoControlDropdown
      With .Controls.Add(Type:=msoControlButton, Temporary:=False)
          .Caption = "Select"
          .Style = msoButtonCaption
          .OnAction = "selectChart"
          .Enabled = True
      End With
      With .Controls.Add(Type:=msoControlButton, Temporary:=False)
          .Caption = "Delete"
          .Style = msoButtonCaption
          .OnAction = "deleteChart"
          .Enabled = True
      End With
      With .Controls.Add(Type:=msoControlButton, Temporary:=False)
          .Caption = "Refresh"
          .Style = msoButtonCaption
          .OnAction = "refresh"
          .TooltipText = "Clears names of all charts from the list, whether charts are still in document or not"
          .Enabled = True
      End With
  End With
End Sub

Sub myDocumentClose()
  Dim sl As CommandBar

  On Error Resume Next
  Set sl = CommandBars("Sparklines")
  If sl Then sl.Delete
End Sub

Sub lineCharts(theHeight, widthMul, showAvg)
  noTb = False
  Dim sl As CommandBar
  On Error GoTo makeToolbar
  Set sl = CommandBars("Sparklines")

continueWithTb:
  howMany = Selection.Range.Paragraphs.Count
  If howMany < 1 Then End

  lines = Split(Selection.Range.Text, vbCr)
  theHeader = ""
  For i = 0 To howMany - 1
      theShapes = lineChart(lines(i), theHeight, widthMul, showAvg, 100 + i * (theHeight + 15), theHeader)
      shapesStrTemp = ""
      For Each elem In theShapes
          shapesStrTemp = shapesStrTemp & "," & elem
      Next
      shapesStr = Right(shapesStrTemp, Len(shapesStrTemp) - 1)
      sl.Controls(2).AddItem theHeader & ":" & shapesStr
  Next i

  Exit Sub
makeToolbar:
  myDocumentOpen
  GoTo continueWithTb
End Sub

Sub lineChartGui()
  frmLineChart.Show
End Sub

Yup, very complicated. Hopefully will become simpler and simpler in future iterations. Sometimes wonder why I don't just switch to automating Excel charts.