[RESOLVED] Sharing the horror of my Excel report export code

[disruptivehair]

This code accepts a sql string as a parameter and it downloads the necessary data, throws it into an Excel sheet, then draws three graphs based on the data it has just downloaded. The requirement is for the report to look just like its old Access counterpart, hence a lot of hard-coding has to take place.

Any way to improve this = much appreciated. I'm ready for the absolute worst of criticisms.

Thank you.

Public Sub CreateExcelWS(strSQL As String)
 
    Call LoadCaption(True)
 
    ' Checks connection to SQL Server; there should be a connection already
    ' but if there isn't it creates one; if the connection is closed (should
    ' not be) then it opens it.
    Call CheckConnection
    
    Dim objRSArray() As ADODB.Recordset
    Dim objRS As ADODB.Recordset
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim xlChartArray(3) As Object
    Dim i As Integer
    Dim strSource(3) As String
    Dim strParameter As String
    Dim strSproc() As String
    Dim StartPosition(3) As Integer
    
    ' Checks to see if there is already an instance of Excel; if there is
    ' then the current one is used, if not then a new one is created.
    If IsExcelInstalled = True And IsExcelRunning = False Then
        Set xlApp = CreateObject("Excel.Application")
    Else
        Set xlApp = GetObject(, "Excel.Application")
    End If
    
    ' Instantiates Excel objects
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.ActiveSheet
    xlSheet.Name = "Sheet 1"
    
    ' Calls UnpackString() function and assigns the output to the strSproc array
    strSproc = UnpackString("SELECT SQLObject FROM tblReports WHERE ReportName = 'Weekly Summary'")
        
    ' Calls the DeriveWhereClause function and assigns the output to strParameter
    strParameter = DeriveWhereClause
    
    ' Sets up the strSource array using the strSproc array
    For i = 0 To UBound(strSproc)
        strSource(i) = "EXEC " & strSproc(i) & " @Filter = " & "'" & strParameter & "'"
    Next i
   
    ReDim objRSArray(UBound(strSproc))
    ' Instantiates and opens the members of the recordset array and
    ' sets the cursorlocation property so that we can use the
    ' recordcount property later on.
    For i = 0 To UBound(strSproc)
        Set objRSArray(i) = New ADODB.Recordset
        objRSArray(i).CursorLocation = adUseClient
        objRSArray(i).Open strSource(i), cnConn, adOpenForwardOnly, adLockReadOnly, adCmdText
    Next i
    
    
    ' Initializes StartPosition(1) and moves data to Excel; starting position
    ' is determined by sizes of recordsets
    ' First chart
    StartPosition(1) = 4
    Call MoveDataExcel(objRSArray(0), xlSheet, StartPosition(1))
    ' Second chart
    StartPosition(2) = StartPosition(1) + 2 + objRSArray(0).RecordCount
    Call MoveDataExcel(objRSArray(1), xlSheet, StartPosition(2))
    ' Third chart
    StartPosition(3) = StartPosition(2) + 2 + objRSArray(1).RecordCount
    Call MoveDataExcel(objRSArray(2), xlSheet, StartPosition(3))
    
    ' Instantiates chart objects and adds them to the Excel spreadsheet
    For i = 1 To 3
        Set xlChartArray(i) = xlApp.Charts.Add
        Call CreateXLChart(xlSheet, xlChartArray(i), StartPosition(i), xlColumnStacked, "Sheet 1")
    Next i
    
    ' Moves the charts to an appropriate position and sizes them
    Call MoveXLCharts(xlSheet, 1, 30, 1, 500, 300)
    Call MoveXLCharts(xlSheet, 2, 340, 1, 500, 300)
    Call MoveXLCharts(xlSheet, 3, 650, 1, 500, 300)
    
    ' Custom format the first chart
    With xlSheet.ChartObjects(1).Chart
        .Axes(xlCategory, xlPrimary).CategoryType = xlCategoryScale
        .PlotArea.ClearFormats
        .HasTitle = True
        .HasLegend = False
        .ChartTitle.Characters.Text = "Applications Received"
        .ChartTitle.Font.Size = 8
        .Axes(xlValue).TickLabels.Font.Size = 9
        .HasDataTable = True
        With .DataTable
            .ShowLegendKey = True
            .Font.Size = 9
        End With
        ' Changes 'Other Protection' series color to red
        .SeriesCollection(4).Interior.ColorIndex = 6
        ' Changes 'Term' series color to light green
        .SeriesCollection(3).Interior.ColorIndex = 24
        ' Changes 'MLI' series color to bluey-purple
        .SeriesCollection(2).Interior.ColorIndex = 22
        ' Changes 'PTA' series color to pale yellow
        .SeriesCollection(5).Interior.ColorIndex = 3
        ' Changes 'Low Touch' series color to white
        .SeriesCollection(6).Interior.ColorIndex = 2
        ' Removes the prop total series from the graph but not
        ' from the data table
        With .SeriesCollection(1)
            .ChartType = xlLine
            .Border.Weight = xlThin
            .Border.LineStyle = xlNone
        End With
    End With
    
    ' Custom format the second chart
    With xlSheet.ChartObjects(2).Chart
        .Axes(xlCategory, xlPrimary).CategoryType = xlCategoryScale
        .PlotArea.ClearFormats
        .HasTitle = True
        .HasLegend = False
        .ChartTitle.Characters.Text = "Cases Accepted - UW Decision Made"
        .ChartTitle.Font.Size = 8
        .Axes(xlValue).TickLabels.Font.Size = 9
        .HasDataTable = True
        .DataTable.ShowLegendKey = True
        .DataTable.Font.Size = 9
    End With
    
    ' Custom format the third chart
    With xlSheet.ChartObjects(3).Chart
        .Axes(xlCategory, xlPrimary).CategoryType = xlCategoryScale
        .PlotArea.ClearFormats
        .HasTitle = True
        .HasLegend = False
        .ChartTitle.Characters.Text = "Applications Issued"
        .ChartTitle.Font.Size = 8
        .Axes(xlValue).TickLabels.Font.Size = 9
        .HasDataTable = True
        With .DataTable
            .ShowLegendKey = True
            .Font.Size = 9
        End With
        .SeriesCollection(3).Interior.ColorIndex = 6
        .SeriesCollection(4).Interior.ColorIndex = 3
        .SeriesCollection(5).Interior.ColorIndex = 2
        .SeriesCollection(6).Interior.ColorIndex = 15
    End With
    
    ' Grab the rundate off the server since we need it for the
    ' report title 'as at' value
    Dim strDate As String
    Set objRS = cnConn.Execute("SELECT RunDate FROM DateRanges")
    strDate = objRS.Fields(0).Value
    
    ' Set up report titles
    Call CreateReportTitles(xlSheet, "A1:E2", xlGeneral, "NB Protection Volumes As At: " & strDate, 12)
    Call CreateReportTitles(xlSheet, "F1:J1", 4, GetgVarPrimInfoValue(), 8)
    Call CreateReportTitles(xlSheet, "F2:J2", 4, AdditionalInfo(GetgVarAddInfoType(), GetgVarAddInfoValue()), 8)
    
    ' Sets up page margins and forces the data all onto one page.
    With xlSheet.PageSetup
        .LeftMargin = 0.4
        .RightMargin = 0.4
        .Zoom = False
        .FitToPagesTall = 1
        .FitToPagesWide = 1
    End With
    
    ' Cells in the given range will have a white font
    xlSheet.Range("A4:I60").Font.ColorIndex = 2
    
    ' Makes Excel visible
    xlApp.Visible = True
    
    Call LoadCaption(False)
    
    ' Destroy objects
    For i = 0 To UBound(strSproc)
        objRSArray(i).Close
        Set objRSArray(i) = Nothing
    Next i
    Set objRS = Nothing
    Set xlChartArray(0) = Nothing
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
End Sub

UnpackString takes the comma-delimited list of three stored procedures that are the sources for the three graphs and presents them in a way that VB can deal with them:

Public Function UnpackString(strVal As String)
    
    Dim rst As ADODB.Recordset
    Dim strArray() As String
    Dim intMemCount As Integer
    
    Set rst = New ADODB.Recordset
    rst.Open strVal, cnConn, adOpenForwardOnly, adLockReadOnly, adCmdText
    
    strArray = Split(rst.GetString, ",")
    intMemCount = UBound(strArray)
  
    ' CleanString cuts off the unwanted gremlin character at the end
    strArray(intMemCount) = CleanString(strArray(intMemCount))
    UnpackString = strArray
 
    rst.Close
    Set rst = Nothing
    
End Function

MoveDataExcel:

Public Sub MoveDataExcel(rstExport As ADODB.Recordset, xlSheet As Object, intStartLine As Integer)
 
    Dim i As Integer
    For i = 0 To rstExport.Fields.Count - 1
        xlSheet.Cells(intStartLine, i + 1).Value = rstExport.Fields(i).Name
    Next i
    
    xlSheet.Range("A" & intStartLine + 1).CopyFromRecordset rstExport
    
End Sub

MoveXLCharts:

Public Sub MoveXLCharts(xlSheet As Object, chartNum As Integer, _
    Top, Left, Width, Height As Integer)
 
    With xlSheet
        With .ChartObjects(chartNum)
            .Top = Top
            .Left = Left
            .Width = Width
            .Height = Height
        End With
    End With
    
End Sub