Send, and hear about the great bullet graph program you've written? I
don't think that would be a good idea
. Here ya go:
'Code behind form
Private Sub cmdMakeBulletGraph_Click()
Dim strOut As String
Dim strFileOut As String
Dim strCR As String
Dim dblFontBBFactor As Double
Dim dblTextToGraphGap As Double
Dim dblSubCaptionSink As Double
Dim varArguments(42) As Variant
Dim iMainCaption As Integer 'Str
Dim iSubCaption As Integer 'Str
Dim iFinishedValue As Integer 'Dbl
Dim iProjectedValue As Integer 'Dbl
Dim iBudgetedValue As Integer 'Dbl
Dim iBudgetedBarHeight As Integer 'Dbl
Dim iBudgetedBarWidth As Integer 'Dbl
Dim iThermometerHeight As Integer 'Dbl
Dim iBarAreaHeight As Integer 'Dbl
Dim iBarAreaWidth As Integer 'Dbl
Dim iTickHeight As Integer 'Dbl
Dim iTickWidth As Integer 'Dbl
Dim iNumberOfAxisTicks As Integer 'Int
Dim iXValueMin As Integer 'Dbl
Dim iXValueMax As Integer 'Dbl
Dim iMainCaptionOriginX As Integer 'Dbl
Dim iMainCaptionOriginY As Integer 'Dbl
Dim iSubCaptionOriginX As Integer 'Dbl
Dim iSubCaptionOriginY As Integer 'Dbl
Dim iBarAreaOriginX As Integer 'Dbl
Dim iBarAreaOriginY As Integer 'Dbl
Dim iMainCaptionFont As Integer 'Str
Dim iMainCaptionFontSize As Integer 'Dbl
Dim iSubCaptionFont As Integer 'Str
Dim iSubCaptionFontSize As Integer 'Dbl
Dim iXAxisFont As Integer 'Str
Dim iXAxisFontSize As Integer 'Dbl
Dim iProjectedR As Integer 'Dbl
Dim iProjectedG As Integer 'Dbl
Dim iProjectedB As Integer 'Dbl
Dim iGray1Color As Integer 'Dbl
Dim iGray2Color As Integer 'Dbl
Dim iGray3Color As Integer 'Dbl
Dim iGray1Value As Integer 'Dbl
Dim iGray2Value As Integer 'Dbl
Dim iGray3Value As Integer 'Dbl
Dim iFinishedR As Integer 'Dbl
Dim iFinishedG As Integer 'Dbl
Dim iFinishedB As Integer 'Dbl
Dim iBudgetedR As Integer 'Dbl
Dim iBudgetedG As Integer 'Dbl
Dim iBudgetedB As Integer 'Dbl
Dim iTickGray As Integer 'Dbl
dblFontBBFactor = 0.9
dblTextToGraphGap = 9
dblSubCaptionSink = 2
iMainCaption = 0
iSubCaption = 1
iFinishedValue = 2
iProjectedValue = 3
iBudgetedValue = 4
iBudgetedBarHeight = 5
iBudgetedBarWidth = 6
iThermometerHeight = 7
iBarAreaHeight = 8
iBarAreaWidth = 9
iTickHeight = 10
iTickWidth = 11
iNumberOfAxisTicks = 12
iXValueMin = 13
iXValueMax = 14
iMainCaptionFont = 15
iMainCaptionFontSize = 16
iSubCaptionFont = 17
iSubCaptionFontSize = 18
iXAxisFont = 19
iXAxisFontSize = 20
iBarAreaOriginX = 21
iBarAreaOriginY = 22
iMainCaptionOriginX = 23
iMainCaptionOriginY = 24
iSubCaptionOriginX = 25
iSubCaptionOriginY = 26
iProjectedR = 27
iProjectedG = 28
iProjectedB = 29
iGray1Color = 30
iGray2Color = 31
iGray3Color = 32
iGray1Value = 33
iGray2Value = 34
iGray3Value = 35
iFinishedR = 36
iFinishedG = 37
iFinishedB = 38
iBudgetedR = 39
iBudgetedG = 40
iBudgetedB = 41
iTickGray = 42
varArguments(iMainCaption) = "Revenue Q1 2005"
varArguments(iSubCaption) = "(U.S. $ in thousands)"
varArguments(iFinishedValue) = 60.71
varArguments(iProjectedValue) = 259.3
varArguments(iBudgetedValue) = 250
varArguments(iBudgetedBarHeight) = 14
varArguments(iBudgetedBarWidth) = 1.4
varArguments(iThermometerHeight) = 6.5
varArguments(iBarAreaHeight) = 20
varArguments(iBarAreaWidth) = 253
varArguments(iTickHeight) = 5.5
varArguments(iTickWidth) = 0.2
varArguments(iNumberOfAxisTicks) = 7
varArguments(iXValueMin) = 0
varArguments(iXValueMax) = 300
varArguments(iMainCaptionFont) = "Helvetica"
varArguments(iMainCaptionFontSize) = 9
varArguments(iSubCaptionFont) = "Helvetica"
varArguments(iSubCaptionFontSize) = 7
varArguments(iXAxisFont) = "Helvetica"
varArguments(iXAxisFontSize) = 7
varArguments(iBarAreaOriginX) = 227
varArguments(iBarAreaOriginY) = 576
'Right align the captions dblTextToGraphGap (9) pts to the left of the
bars
'The origins should probably be done in the function instead
varArguments(iMainCaptionOriginX) = varArguments(iBarAreaOriginX) -
dblTextToGraphGap - GetFontWidth(CStr(varArguments(iMainCaption)), CStr
(varArguments(iMainCaptionFont)), CDbl(varArguments
(iMainCaptionFontSize)))
'Line the Caption up with the center bar
varArguments(iMainCaptionOriginY) = varArguments(iBarAreaOriginY) +
varArguments(iBarAreaHeight) / 2 - varArguments(iMainCaptionFontSize)
* dblFontBBFactor / 2
'Right align the captions dblTextToGraphGap (9) pts to the left of the
bars
varArguments(iSubCaptionOriginX) = varArguments(iBarAreaOriginX) -
dblTextToGraphGap - GetFontWidth(CStr(varArguments(iSubCaption)), CStr
(varArguments(iSubCaptionFont)), CDbl(varArguments
(iSubCaptionFontSize)))
'Line the SubCaption so that the top is about 2 pts below the bar
varArguments(iSubCaptionOriginY) = varArguments(iBarAreaOriginY) -
varArguments(iSubCaptionFontSize) * dblFontBBFactor -
dblSubCaptionSink
varArguments(iProjectedR) = 0.38
varArguments(iProjectedG) = 0.565
varArguments(iProjectedB) = 0.784
varArguments(iGray1Color) = 0.659
varArguments(iGray2Color) = 0.781
varArguments(iGray3Color) = 0.907
varArguments(iGray1Value) = 200
varArguments(iGray2Value) = 250
varArguments(iGray3Value) = 300
varArguments(iFinishedR) = 0.118
varArguments(iFinishedG) = 0.443
varArguments(iFinishedB) = 0.722
varArguments(iBudgetedR) = 0.165
varArguments(iBudgetedG) = 0.467
varArguments(iBudgetedB) = 0.725
varArguments(iTickGray) = 0.659
strCR = Chr(13)
strFileOut = "C:\TestBulletGraph.txt"
strOut = DrawHorizontalBulletGraph(varArguments())
Open strFileOut For Output As #1
Print #1, strOut
Close
MsgBox ("Done.")
End Sub
'End Code behind form
'Module Code
Public Function DrawHorizontalBulletGraph(varInput() As Variant) As
String
Dim strTemp As String
Dim strCR As String
Dim I As Integer
Dim dblCurXLabelX As Double
Dim dblCurXLabelY As Double
Dim iMainCaption As Integer 'Str
Dim iSubCaption As Integer 'Str
Dim iFinishedValue As Integer 'Dbl
Dim iProjectedValue As Integer 'Dbl
Dim iBudgetedValue As Integer 'Dbl
Dim iBudgetedBarHeight As Integer 'Dbl
Dim iBudgetedBarWidth As Integer 'Dbl
Dim iThermometerHeight As Integer 'Dbl
Dim iBarAreaHeight As Integer 'Dbl
Dim iBarAreaWidth As Integer 'Dbl
Dim iTickHeight As Integer 'Dbl
Dim iTickWidth As Integer 'Dbl
Dim iNumberOfAxisTicks As Integer 'Int
Dim iXValueMin As Integer 'Dbl
Dim iXValueMax As Integer 'Dbl
Dim iMainCaptionOriginX As Integer 'Dbl
Dim iMainCaptionOriginY As Integer 'Dbl
Dim iSubCaptionOriginX As Integer 'Dbl
Dim iSubCaptionOriginY As Integer 'Dbl
Dim iBarAreaOriginX As Integer 'Dbl
Dim iBarAreaOriginY As Integer 'Dbl
Dim iMainCaptionFont As Integer 'Str
Dim iMainCaptionFontSize As Integer 'Dbl
Dim iSubCaptionFont As Integer 'Str
Dim iSubCaptionFontSize As Integer 'Dbl
Dim iXAxisFont As Integer 'Str
Dim iXAxisFontSize As Integer 'Dbl
Dim iProjectedR As Integer 'Dbl
Dim iProjectedG As Integer 'Dbl
Dim iProjectedB As Integer 'Dbl
Dim iGray1Color As Integer 'Dbl
Dim iGray2Color As Integer 'Dbl
Dim iGray3Color As Integer 'Dbl
Dim iGray1Value As Integer 'Dbl
Dim iGray2Value As Integer 'Dbl
Dim iGray3Value As Integer 'Dbl
Dim iFinishedR As Integer 'Dbl
Dim iFinishedG As Integer 'Dbl
Dim iFinishedB As Integer 'Dbl
Dim iBudgetedR As Integer 'Dbl
Dim iBudgetedG As Integer 'Dbl
Dim iBudgetedB As Integer 'Dbl
Dim iTickGray As Integer 'Dbl
Dim dblXAxisValues() As Double
Dim dblTickX() As Double
Dim intFontNumber As Integer
iMainCaption = 0
iSubCaption = 1
iFinishedValue = 2
iProjectedValue = 3
iBudgetedValue = 4
iBudgetedBarHeight = 5
iBudgetedBarWidth = 6
iThermometerHeight = 7
iBarAreaHeight = 8
iBarAreaWidth = 9
iTickHeight = 10
iTickWidth = 11
iNumberOfAxisTicks = 12
iXValueMin = 13
iXValueMax = 14
iMainCaptionFont = 15
iMainCaptionFontSize = 16
iSubCaptionFont = 17
iSubCaptionFontSize = 18
iXAxisFont = 19
iXAxisFontSize = 20
iBarAreaOriginX = 21
iBarAreaOriginY = 22
iMainCaptionOriginX = 23
iMainCaptionOriginY = 24
iSubCaptionOriginX = 25
iSubCaptionOriginY = 26
iProjectedR = 27
iProjectedG = 28
iProjectedB = 29
iGray1Color = 30
iGray2Color = 31
iGray3Color = 32
iGray1Value = 33
iGray2Value = 34
iGray3Value = 35
iFinishedR = 36
iFinishedG = 37
iFinishedB = 38
iBudgetedR = 39
iBudgetedG = 40
iBudgetedB = 41
iTickGray = 42
ReDim dblXAxisValues(varInput(iNumberOfAxisTicks)) As Double
ReDim dblTickX(varInput(iNumberOfAxisTicks)) As Double
For I = 1 To varInput(iNumberOfAxisTicks)
dblXAxisValues(I) = varInput(iXValueMin) + (I - 1) * (varInput
(iXValueMax) - varInput(iXValueMin)) / (varInput(iNumberOfAxisTicks) -
1)
dblTickX(I) = varInput(iBarAreaOriginX) + varInput(iBarAreaWidth) *
(I - 1) / (varInput(iNumberOfAxisTicks) - 1)
Next I
strCR = Chr(13)
strTemp = "%Bullet Graph" & strCR
strTemp = strTemp & "q" & strCR
'Draw the gray rectangles
'strTemp = strTemp & "" & strCR
strTemp = strTemp & "q" & strCR
strTemp = strTemp & "0.01 w" & strCR
strTemp = strTemp & varInput(iGray3Color) & " g" & strCR 'fill color
strTemp = strTemp & varInput(iGray3Color) & " G" & strCR 'border color
'strTemp = strTemp & varInput(iBarAreaOriginX) & " " & varInput
(iBarAreaOriginY) & " " & varInput(iBarAreaWidth) & " " & varInput
(iBarAreaHeight) & " re" & strCR
'Allow the lightest gray background to go beyond the last tick mark
strTemp = strTemp & varInput(iBarAreaOriginX) & " " & varInput
(iBarAreaOriginY) & " " & ValToPts(CDbl(varInput(iGray3Value)), CDbl
(varInput(iXValueMin)), CDbl(varInput(iXValueMax)), CDbl(varInput
(iBarAreaWidth))) & " " & varInput(iBarAreaHeight) & " re" & strCR
strTemp = strTemp & "b S" & strCR
strTemp = strTemp & "Q" & strCR
strTemp = strTemp & "q" & strCR
strTemp = strTemp & "0.01 w" & strCR
strTemp = strTemp & varInput(iGray2Color) & " g" & strCR
strTemp = strTemp & varInput(iGray2Color) & " G" & strCR
strTemp = strTemp & varInput(iBarAreaOriginX) & " " & varInput
(iBarAreaOriginY) & " " & ValToPts(CDbl(varInput(iGray2Value)), CDbl
(varInput(iXValueMin)), CDbl(varInput(iXValueMax)), CDbl(varInput
(iBarAreaWidth))) & " " & varInput(iBarAreaHeight) & " re" & strCR
strTemp = strTemp & "b S" & strCR
strTemp = strTemp & "Q" & strCR
strTemp = strTemp & "q" & strCR
strTemp = strTemp & "0.01 w" & strCR
strTemp = strTemp & varInput(iGray1Color) & " g" & strCR
strTemp = strTemp & varInput(iGray1Color) & " G" & strCR
strTemp = strTemp & varInput(iBarAreaOriginX) & " " & varInput
(iBarAreaOriginY) & " " & ValToPts(CDbl(varInput(iGray1Value)), CDbl
(varInput(iXValueMin)), CDbl(varInput(iXValueMax)), CDbl(varInput
(iBarAreaWidth))) & " " & varInput(iBarAreaHeight) & " re" & strCR
strTemp = strTemp & "b S" & strCR
strTemp = strTemp & "Q" & strCR
'Draw the ticks and X-Axis numbers
For I = 1 To varInput(iNumberOfAxisTicks)
strTemp = strTemp & "q" & strCR
strTemp = strTemp & "0.01 w" & strCR
strTemp = strTemp & varInput(iTickGray) & " g" & strCR 'fill color
strTemp = strTemp & varInput(iTickGray) & " G" & strCR 'border color
strTemp = strTemp & CStr(dblTickX(I) - varInput(iTickWidth) / 2) & "
" & varInput(iBarAreaOriginY) - varInput(iTickHeight) & " " & varInput
(iTickWidth) & " " & varInput(iTickHeight) & " re" & strCR
strTemp = strTemp & "b S" & strCR
strTemp = strTemp & "Q" & strCR
strTemp = strTemp & "BT" & strCR
intFontNumber = GetFontNumber(CStr(varInput(iXAxisFont)))
strTemp = strTemp & "/F" & CStr(intFontNumber) & " " & CStr(varInput
(iXAxisFontSize)) & " Tf" & strCR
strTemp = strTemp & dblTickX(I) - GetFontWidth(Format(dblXAxisValues
(I), "0"), CStr(varInput(iXAxisFont)), CDbl(varInput
(iXAxisFontSize))) / 2 & " " & varInput(iBarAreaOriginY) - varInput
(iTickHeight) - 4 - varInput(iXAxisFontSize) * 0.85 & "1 Td" & strCR
strTemp = strTemp & "(" & Format(dblXAxisValues(I), "0") & ") Tj" &
strCR
strTemp = strTemp & "ET" & strCR
Next I
'Draw the captions
strTemp = strTemp & "BT" & strCR
intFontNumber = GetFontNumber(CStr(varInput(iMainCaptionFont)))
strTemp = strTemp & "/F" & CStr(intFontNumber) & " " & CStr(varInput
(iMainCaptionFontSize)) & " Tf" & strCR
strTemp = strTemp & CStr(varInput(iMainCaptionOriginX)) & " " & CStr
(varInput(iMainCaptionOriginY)) & "1 Td" & strCR
strTemp = strTemp & "(" & TLit(CStr(varInput(iMainCaption))) & ") Tj"
& strCR
strTemp = strTemp & "ET" & strCR
strTemp = strTemp & "BT" & strCR
intFontNumber = GetFontNumber(CStr(varInput(iSubCaptionFont)))
strTemp = strTemp & "/F" & CStr(intFontNumber) & " " & CStr(varInput
(iSubCaptionFontSize)) & " Tf" & strCR
strTemp = strTemp & CStr(varInput(iSubCaptionOriginX)) & " " & CStr
(varInput(iSubCaptionOriginY)) & "1 Td" & strCR
strTemp = strTemp & "(" & TLit(CStr(varInput(iSubCaption))) & ") Tj" &
strCR
strTemp = strTemp & "ET" & strCR
'Draw the projected bar
strTemp = strTemp & "q" & strCR
strTemp = strTemp & "0.01 w" & strCR
strTemp = strTemp & varInput(iProjectedR) & " " & varInput
(iProjectedG) & " " & varInput(iProjectedB) & " rg" & strCR
strTemp = strTemp & varInput(iProjectedR) & " " & varInput
(iProjectedG) & " " & varInput(iProjectedB) & " RG" & strCR
strTemp = strTemp & varInput(iBarAreaOriginX) & " " & varInput
(iBarAreaOriginY) + varInput(iBarAreaHeight) / 2 - varInput
(iThermometerHeight) / 2 & " " & ValToPts(CDbl(varInput
(iProjectedValue)), CDbl(varInput(iXValueMin)), CDbl(varInput
(iXValueMax)), CDbl(varInput(iBarAreaWidth))) & " " & varInput
(iThermometerHeight) & " re" & strCR
strTemp = strTemp & "b S" & strCR
strTemp = strTemp & "Q" & strCR
'Draw the finished bar
strTemp = strTemp & "q" & strCR
strTemp = strTemp & "0.01 w" & strCR
strTemp = strTemp & varInput(iFinishedR) & " " & varInput(iFinishedG)
& " " & varInput(iFinishedB) & " rg" & strCR
strTemp = strTemp & varInput(iFinishedR) & " " & varInput(iFinishedG)
& " " & varInput(iFinishedB) & " RG" & strCR
strTemp = strTemp & varInput(iBarAreaOriginX) & " " & varInput
(iBarAreaOriginY) + varInput(iBarAreaHeight) / 2 - varInput
(iThermometerHeight) / 2 & " " & ValToPts(CDbl(varInput
(iFinishedValue)), CDbl(varInput(iXValueMin)), CDbl(varInput
(iXValueMax)), CDbl(varInput(iBarAreaWidth))) & " " & varInput
(iThermometerHeight) & " re" & strCR
strTemp = strTemp & "b S" & strCR
strTemp = strTemp & "Q" & strCR
'Draw the budgeted mark
strTemp = strTemp & "q" & strCR
strTemp = strTemp & "0.01 w" & strCR
strTemp = strTemp & varInput(iBudgetedR) & " " & varInput(iBudgetedG)
& " " & varInput(iBudgetedB) & " rg" & strCR
strTemp = strTemp & varInput(iBudgetedR) & " " & varInput(iBudgetedG)
& " " & varInput(iBudgetedB) & " RG" & strCR
strTemp = strTemp & varInput(iBarAreaOriginX) + ValToPts(CDbl(varInput
(iBudgetedValue)), CDbl(varInput(iXValueMin)), CDbl(varInput
(iXValueMax)), CDbl(varInput(iBarAreaWidth))) - CDbl(varInput
(iBudgetedBarWidth)) / 2 & " " & varInput(iBarAreaOriginY) + varInput
(iBarAreaHeight) / 2 - varInput(iBudgetedBarHeight) / 2 & " " &
varInput(iBudgetedBarWidth) & " " & varInput(iBudgetedBarHeight) & "
re" & strCR
strTemp = strTemp & "b S" & strCR
strTemp = strTemp & "Q" & strCR
DrawHorizontalBulletGraph = strTemp
End Function
Private Function ValToPts(dblV As Double, dblMinValue As Double,
dblMaxValue As Double, dblRangePts As Double) As Double
ValToPts = dblV * dblRangePts / (dblMaxValue - dblMinValue)
End Function
Function TLit(strIn As String) As String
Dim strTemp As String
Dim intI As Integer
Dim strChar As String
'Transform Literals
TLit = ""
If Len(strIn) = 0 Then Exit Function
For intI = 1 To Len(strIn)
strChar = Mid(strIn, intI, 1)
Select Case strChar
Case "\":
strTemp = strTemp & "\\"
Case "(":
strTemp = strTemp & "\("
Case ")":
strTemp = strTemp & "\)"
Case Else
strTemp = strTemp & strChar
End Select
Next intI
TLit = strTemp
End Function
Public Function GetFontNumber(strFontName) As Integer
Select Case strFontName
Case "Courier":
GetFontNumber = 1
Case "CourierBold":
GetFontNumber = 2
Case "Helvetica":
GetFontNumber = 3
Case "HelveticaBold":
GetFontNumber = 4
Case Else
GetFontNumber = 0
End Select
End Function
'End Module Code
That should produce a layout text file that can be imported into the
PDFLayoutViewer I posted and used to create a PDF (The existing
Portrait mode is adequate). I put a bunch of controls on the form so
that I can test the function further, but haven't gotten around to
hooking the array values up to the form controls yet. The PDF ellipse
code I posted not long ago can be incorporated to make an elliptical
marker if you really want to make an impression. Inside a report loop
it is only necessary to change a few array elements once the array
defaults are set up. I have created some functions that center or
justify text and automatically scale the text to fit, but those
haven't been added yet either. Those functions allow me to replace
the five or six lines of text creation code with a single function
call. My idea for a job report is to use different colors for the
thermometer part depending on whether the job is on budget, leaning
toward being over budget (projected goes past the marker) or actually
over budget (actual goes past the marker - guess what color I'll use
for that). That should at least get you going on your worthy
endeavor.
James A. Fortune
(e-mail address removed)
