'***********************************************************'* Module Name: MSExcel'* Author:      Steve Miller'* Date:        11/22/98'* Description: Encapsulates and eases the chore of writing to an Excel ' spreadsheet.'*'* IMPORTANT: requires that you have a reference to Excel type library'*'* Example:     Here is an example of how to use this class:'*   Dim objXL As New ttExcel.Application                   'Instantiate the ' object'*   Call objXL.OpenExcelFile(FileName:="c:SMTest.xls",'  '*        WorkSheetName:="MyWorksheet", '*        AppendDayofWk:=True)       '                        'Open the Excel file'*   Call objXL.StoreExcelRow(A:="Hello", B:="World")       'Write a row to the ' Excel file'*   Call objXL.StoreExcelBlankRows(NbrRows:=10)            'Skip blank rows in ' the Excel file'*   Call objXL.StoreExcelRow(A:="Skipped 10 rows")'*   Call objXL.SetExcelCellWidthAutoFit                    'Auto size the ' column widths'*   Call objXL.SetExcelCellWidth(Cell:="A", Width:=25)     'Manually set a ' column width'*   Call objXL.CloseExcelFile                              'Close the Excel ' file'*   Set objXL = Nothing                                    'Cleanup (release ' memory)'***********************************************************Option Compare TextOption Base 1                    'Start arrays at element 1 instead of 0'ConstantsPrivate Const m_constPgm As String = "MSExcel."Private Const m_lngExcelLabelNotFound = 1004'ObjectsPrivate m_objWorkbook             As WorkbookPrivate m_objWorksheet            As WorksheetPrivate m_objXL                   As Excel.ApplicationPrivate m_objPageSetup            As Excel.PageSetupPrivate m_lxPageOrientation       As XlPageOrientation'StringsPrivate m_strExcelFileName          As String'LongsPrivate m_lngExcelRow               As Long     'SM 6/24/98 Used for Excel Row                                                 ' Number'*--------------------------------------------------------------'* StoreExcelRow'* - Common routine used for writing a row to Excel.  The nice thing about this'*   routine is that you do not have to keep up with the row number.  It will'*   automatically increment the row number so that you don't have to keep up ' with it.'* - Inputs:'*   A - Z represent columns in Excel.  For example, to write information in'*         column A, you assign information to A.'*   FontBold - True if you want the entire row to be bold (used for headers/' titles)'* - Examples:'*   Call StoreExcelRow(A:="Column A", B:="Column B", FontBold:=True'*   Call StoreExcelRow(A:="12344.33", B:="My Text!", FontBold:=False'*--------------------------------------------------------------Public Sub StoreExcelRow(Optional A As Variant, Optional B As Variant, _    Optional C As Variant, Optional D As Variant, Optional E As Variant, _    Optional F As Variant, Optional G As Variant, Optional H As Variant, _    Optional i As Variant, Optional J As Variant, Optional K As Variant, _    Optional L As Variant, Optional M As Variant, Optional n As Variant, _    Optional O As Variant, Optional P As Variant, Optional Q As Variant, _    Optional R As Variant, Optional S As Variant, Optional T As Variant, _    Optional U As Variant, Optional V As Variant, Optional W As Variant, _    Optional x As Variant, Optional Y As Variant, Optional Z As Variant, _    Optional FontBold As Boolean = False, Optional FontSize As Integer, _    Optional FontItalic As Boolean = False, Optional FontOutline As Boolean = _    False, Optional FontColor As Variant, Optional ALabel As Variant, _    Optional BLabel As Variant, Optional CLabel As Variant, _    Optional DLabel As Variant, Optional ELabel As Variant, _    Optional FLabel As Variant, Optional GLabel As Variant, _    Optional HLabel As Variant, Optional ILabel As Variant, _    Optional JLabel As Variant, Optional KLabel As Variant, _    Optional LLabel As Variant, Optional MLabel As Variant, _    Optional nLabel As Variant, Optional OLabel As Variant, _    Optional PLabel As Variant, Optional QLabel As Variant, _    Optional RLabel As Variant, Optional SLabel As Variant, _    Optional TLabel As Variant, Optional ULabel As Variant, _    Optional VLabel As Variant, Optional WLabel As Variant, _    Optional XLabel As Variant, Optional YLabel As Variant, _    Optional ZLabel As Variant, Optional BorderHeader As Boolean = False, _    Optional BorderAround = False)   On Error GoTo ErrorHandler   Const constErrRoutine As String = "StoreExcelRow"   Dim strBeginCell As String   Dim strEndCell As String   Dim intCounter As Integer   Dim intBegin As Integer   Dim intEnd As Integer   Const constCells As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"   Const constBeige As Variant = &HC0FFFF   Const constDarkBlue As Variant = &H800000   If m_objWorksheet Is Nothing Then      Err.Raise 1000, "ttExcel.CreateExcelFromADORecordset", _          "You must first invoke the OpenExcelFile method before calling this " _          & "method."      GoTo ExitMe   End If   m_lngExcelRow = m_lngExcelRow + 1   If Not IsMissing(A) Then      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow))).Value = CStr(A)      strBeginCell = "A"   End If   If Not IsMissing(B) Then      m_objWorksheet.Range("B" & Trim(Str(m_lngExcelRow))).Value = CStr(B)      If strBeginCell = "" Then         strBeginCell = "B"      Else         strEndCell = "B"      End If   End If   If Not IsMissing(C) Then      m_objWorksheet.Range("C" & Trim(Str(m_lngExcelRow))).Value = CStr(C)      If strBeginCell = "" Then         strBeginCell = "C"      Else         strEndCell = "C"      End If   End If   If Not IsMissing(D) Then      m_objWorksheet.Range("D" & Trim(Str(m_lngExcelRow))).Value = CStr(D)      If strBeginCell = "" Then         strBeginCell = "D"      Else         strEndCell = "D"      End If   End If   If Not IsMissing(E) Then      m_objWorksheet.Range("E" & Trim(Str(m_lngExcelRow))).Value = CStr(E)      If strBeginCell = "" Then         strBeginCell = "E"      Else         strEndCell = "E"      End If   End If   If Not IsMissing(F) Then      m_objWorksheet.Range("F" & Trim(Str(m_lngExcelRow))).Value = CStr(F)      If strBeginCell = "" Then         strBeginCell = "F"      Else         strEndCell = "F"      End If   End If   If Not IsMissing(G) Then      m_objWorksheet.Range("G" & Trim(Str(m_lngExcelRow))).Value = CStr(G)      If strBeginCell = "" Then         strBeginCell = "G"      Else         strEndCell = "G"      End If   End If   If Not IsMissing(H) Then      m_objWorksheet.Range("H" & Trim(Str(m_lngExcelRow))).Value = CStr(H)      If strBeginCell = "" Then         strBeginCell = "H"      Else         strEndCell = "H"      End If   End If   If Not IsMissing(i) Then      m_objWorksheet.Range("I" & Trim(Str(m_lngExcelRow))).Value = CStr(i)      If strBeginCell = "" Then         strBeginCell = "I"      Else         strEndCell = "I"      End If   End If   If Not IsMissing(J) Then      m_objWorksheet.Range("J" & Trim(Str(m_lngExcelRow))).Value = CStr(J)      If strBeginCell = "" Then         strBeginCell = "J"      Else         strEndCell = "J"      End If   End If   If Not IsMissing(K) Then      m_objWorksheet.Range("K" & Trim(Str(m_lngExcelRow))).Value = CStr(K)      If strBeginCell = "" Then         strBeginCell = "K"      Else         strEndCell = "K"      End If   End If   If Not IsMissing(L) Then      m_objWorksheet.Range("L" & Trim(Str(m_lngExcelRow))).Value = CStr(L)      If strBeginCell = "" Then         strBeginCell = "L"      Else         strEndCell = "L"      End If   End If   If Not IsMissing(M) Then      m_objWorksheet.Range("M" & Trim(Str(m_lngExcelRow))).Value = CStr(M)      If strBeginCell = "" Then         strBeginCell = "M"      Else         strEndCell = "M"      End If   End If   If Not IsMissing(n) Then      m_objWorksheet.Range("N" & Trim(Str(m_lngExcelRow))).Value = CStr(n)      If strBeginCell = "" Then         strBeginCell = "N"      Else         strEndCell = "N"      End If   End If   If Not IsMissing(O) Then      m_objWorksheet.Range("O" & Trim(Str(m_lngExcelRow))).Value = CStr(O)      If strBeginCell = "" Then         strBeginCell = "O"      Else         strEndCell = "O"      End If   End If   If Not IsMissing(P) Then      m_objWorksheet.Range("P" & Trim(Str(m_lngExcelRow))).Value = CStr(P)      If strBeginCell = "" Then         strBeginCell = "P"      Else         strEndCell = "P"      End If   End If   If Not IsMissing(Q) Then      m_objWorksheet.Range("Q" & Trim(Str(m_lngExcelRow))).Value = CStr(Q)      If strBeginCell = "" Then         strBeginCell = "Q"      Else         strEndCell = "Q"      End If   End If   If Not IsMissing(R) Then      m_objWorksheet.Range("R" & Trim(Str(m_lngExcelRow))).Value = CStr(R)      If strBeginCell = "" Then         strBeginCell = "R"      Else         strEndCell = "R"      End If   End If   If Not IsMissing(S) Then      m_objWorksheet.Range("S" & Trim(Str(m_lngExcelRow))).Value = CStr(S)      If strBeginCell = "" Then         strBeginCell = "S"      Else         strEndCell = "S"      End If   End If   If Not IsMissing(T) Then      m_objWorksheet.Range("T" & Trim(Str(m_lngExcelRow))).Value = CStr(T)      If strBeginCell = "" Then         strBeginCell = "T"      Else         strEndCell = "T"      End If   End If   If Not IsMissing(U) Then      m_objWorksheet.Range("U" & Trim(Str(m_lngExcelRow))).Value = CStr(U)      If strBeginCell = "" Then         strBeginCell = "U"      Else         strEndCell = "U"      End If   End If   If Not IsMissing(V) Then      m_objWorksheet.Range("V" & Trim(Str(m_lngExcelRow))).Value = CStr(V)      If strBeginCell = "" Then         strBeginCell = "V"      Else         strEndCell = "V"      End If   End If   If Not IsMissing(W) Then      m_objWorksheet.Range("W" & Trim(Str(m_lngExcelRow))).Value = CStr(W)      If strBeginCell = "" Then         strBeginCell = "W"      Else         strEndCell = "W"      End If   End If   If Not IsMissing(x) Then      m_objWorksheet.Range("X" & Trim(Str(m_lngExcelRow))).Value = CStr(x)      If strBeginCell = "" Then         strBeginCell = "X"      Else         strEndCell = "X"      End If   End If   If Not IsMissing(Y) Then      m_objWorksheet.Range("Y" & Trim(Str(m_lngExcelRow))).Value = CStr(Y)      If strBeginCell = "" Then         strBeginCell = "Y"      Else         strEndCell = "Y"      End If   End If   If Not IsMissing(Z) Then      m_objWorksheet.Range("Z" & Trim(Str(m_lngExcelRow))).Value = CStr(Z)      If strBeginCell = "" Then         strBeginCell = "Z"      Else         strEndCell = "Z"      End If   End If   If Not IsMissing(ALabel) Then m_objWorksheet.Range("A" & Trim(Str _       (m_lngExcelRow))).Name = ALabel   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Bold = FontBold   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Italic = FontItalic   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.OutlineFont = FontOutline   If IsMissing(FontSize) Or FontSize = 0 Then      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _          (m_lngExcelRow))).Font.Size = 10   Else      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _          (m_lngExcelRow))).Font.Size = FontSize   End If   If Not IsMissing(FontColor) Then      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _          (m_lngExcelRow))).Font.Color = FontColor   End If   If strBeginCell = "" Then strBeginCell = "A"   If strEndCell = "" Then strEndCell = "Z"   If BorderHeader Then      'Show as a heading by making the background dark blue and the font white      intBegin = InStr(1, constCells, strBeginCell)      intEnd = InStr(1, constCells, strEndCell)      For intCounter = intBegin To intEnd         Call DrawCellBorder(Cell:=Mid$(constCells, intCounter, 1), _             InteriorColor:=constDarkBlue)      Next intCounter      m_objWorksheet.Range(strBeginCell & Trim(Str(m_lngExcelRow)) & ":" & _          strEndCell & Trim(Str(m_lngExcelRow))).Font.Color = vbWhite   End If   If BorderAround Then      'Put a thin border around the area and make background beige      intBegin = InStr(1, constCells, strBeginCell)      intEnd = InStr(1, constCells, strEndCell)      For intCounter = intBegin To intEnd         Call DrawCellBorder(Cell:=Mid$(constCells, intCounter, 1), _             InteriorColor:=constBeige)      Next intCounter   End IfExitMe:    Exit SubErrorHandler:    Err.Raise Err.Number, m_constPgm & ".StoreExcelRow", Err.Description    Resume ExitMe   End Sub'*--------------------------------------------------------------'* DrawCellBorder'* - Draws a border around the cell'*--------------------------------------------------------------Private Sub DrawCellBorder(Cell As String, InteriorColor As Variant)   With m_objWorksheet.Range(Cell & Trim(Str(m_lngExcelRow)) & ":" & Cell & _       Trim(Str(m_lngExcelRow)))      .Cells.Interior.Color = InteriorColor      .BorderAround Color:=vbBlack   End WithEnd Sub'*--------------------------------------------------------------'* CreateExcelFromADORecordset'* - Writes the rows from the ADO Recordset'* - Inputs:'*   rst = ADO Recordset'*   Title = Descriptive Title on the spreadsheet'*   FontColor = Color of the font (like vbBlue, vbBlack, etc)'*   FontSize = Size of the font (like 10 pt)'* - Example:     Call CreateExcelFromADORecordset(rst,vbBlue,10)'*--------------------------------------------------------------Public Sub CreateExcelFromADORecordset(rst As Object, _    Optional strTitle As Variant, Optional FontColor As Variant, _    Optional FontSize As Integer)   On Error GoTo ErrorHandler   Const constErrRoutine As String = "CreateExcelFromADORecordset"   Const constCell As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"   Dim i As Integer   Dim sCell As String   Dim vValue As Variant   m_lngExcelRow = m_lngExcelRow + 1   If m_objWorksheet Is Nothing Then      Err.Raise 1000, "ttExcel.CreateExcelFromADORecordset", _          "You must first invoke the OpenExcelFile method before calling this " _          & "method."      GoTo ExitMe   End If   If Not IsMissing(strTitle) Then      StoreExcelBlankRows (4)   End If   If IsMissing(FontSize) Or FontSize = 0 Then      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _          (m_lngExcelRow))).Font.Size = 10   Else      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _          (m_lngExcelRow))).Font.Size = FontSize   End If   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Bold = True   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Color = vbBlue   'First write the column names   For i = 0 To rst.Fields.Count - 1      sCell = Mid(constCell, i + 1, 1) & Trim$(Str(m_lngExcelRow))      vValue = ProperCase(rst.Fields.Item(i).Name)                   'Must put it in a variant to keep from getting error      If IsNumeric(vValue) Then         m_objWorksheet.Range(sCell).Value = Str(vValue)      Else         m_objWorksheet.Range(sCell).Value = vValue      End If   Next i   m_lngExcelRow = m_lngExcelRow + 1   If Not IsMissing(FontColor) Then      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _          (m_lngExcelRow))).Font.Color = FontColor   End If   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Bold = False   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Color = vbBlack   'Now write each row   rst.MoveFirst   Do Until rst.EOF      For i = 0 To rst.Fields.Count - 1         sCell = Mid$(constCell, i + 1, 1) & Trim$(Str(m_lngExcelRow))         vValue = rst.Fields.Item(i).Value         'Must put it in a variant to                                                    ' keep from getting error         If IsNumeric(vValue) Then            m_objWorksheet.Range(sCell).Value = Str(vValue)         Else            m_objWorksheet.Range(sCell).Value = vValue         End If      Next i      rst.MoveNext      m_lngExcelRow = m_lngExcelRow + 1   Loop   SetExcelCellWidthAutoFit   'Now write title if needed   If Not IsMissing(strTitle) Then      m_objWorksheet.Range("A1:Z1").Font.Bold = True      m_objWorksheet.Range("A1:Z1").Font.Color = vbBlack      m_objWorksheet.Range("A1:Z1").Font.Size = 18      m_objWorksheet.Range("A1") = strTitle      m_objWorksheet.Range("A2:Z2").Font.Bold = True      m_objWorksheet.Range("A2:Z2").Font.Color = vbBlack      m_objWorksheet.Range("A2:Z2").Font.Size = 10      m_objWorksheet.Range("A2") = "Run: " & Format$(Now, _          "mmmm dd, yyyy hh:mm AMPM")      m_objWorksheet.Range("A3:Z3").Font.Bold = True      m_objWorksheet.Range("A3:Z3").Font.Color = vbBlack      m_objWorksheet.Range("A3:Z3").Font.Size = 10      m_objWorksheet.Range("A3") = rst.RecordCount & " rows listed below "   End If   'Disable error trap in case this is a forward-only cursor   On Error Resume Next   rst.MoveFirstExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* CreateExcelFromSSOLEDBGrid'* - Writes the rows from the Data Widgets grid'* - Inputs:'*   grd = SSOLEDbGrid'*   Title = Descriptive Title on the spreadsheet'*   FontColor = Color of the font (like vbBlue, vbBlack, etc)'*   FontSize = Size of the font (like 10 pt)'* - Example:     Call CreateExcelFromSSOLEDBGrid(grd,vbBlue,10)'*--------------------------------------------------------------Public Sub CreateExcelFromSSOLEDBGrid(grd As Object, _    Optional strTitle As Variant, Optional FontColor As Variant, _    Optional FontSize As Integer)   On Error GoTo ErrorHandler   Const constErrRoutine As String = "CreateExcelFromSSOLEDBGrid"   Const constCell As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"   Dim i As Integer   Dim n As Integer   Dim sCell As String   Dim vValue As Variant   Dim lngRows As Long   Dim intCols As Integer   grd.redraw = False   m_lngExcelRow = m_lngExcelRow + 1   If m_objWorksheet Is Nothing Then      Err.Raise 1000, "ttExcel.CreateExcelFromSSOLEDBGrid", _          "You must first invoke the OpenExcelFile method before calling this " _          & "method."      GoTo ExitMe   End If   If Not IsMissing(strTitle) Then      StoreExcelBlankRows (4)   End If   If IsMissing(FontSize) Or FontSize = 0 Then      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _          (m_lngExcelRow))).Font.Size = 10   Else      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _          (m_lngExcelRow))).Font.Size = FontSize   End If   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Bold = True   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Color = vbBlue   'First write the column names   intCols = grd.cols - 1   'Only allow 26 columns (columns A-Z in spreadsheet)   If intCols > 26 Then    intCols = 25   End If   For i = 0 To intCols      sCell = Mid(constCell, i + 1, 1) & Trim$(Str(m_lngExcelRow))      vValue = grd.Columns(i).Caption      If IsNumeric(vValue) Then         m_objWorksheet.Range(sCell).Value = Str(vValue)      Else         m_objWorksheet.Range(sCell).Value = vValue      End If   Next i   m_lngExcelRow = m_lngExcelRow + 1   If Not IsMissing(FontColor) Then      m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _          (m_lngExcelRow))).Font.Color = FontColor   End If   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Bold = False   m_objWorksheet.Range("A" & Trim(Str(m_lngExcelRow)) & ":Z" & Trim(Str _       (m_lngExcelRow))).Font.Color = vbBlack   'Now write each row   grd.MoveFirst   lngRows = grd.Rows   For i = 1 To lngRows      For n = 0 To intCols         sCell = Mid$(constCell, n + 1, 1) & Trim$(Str(m_lngExcelRow))         vValue = grd.Columns(n).Text        'Must put it in a variant to keep                                              ' from getting error         If IsNumeric(vValue) Then            m_objWorksheet.Range(sCell).Value = Str(vValue)         Else            m_objWorksheet.Range(sCell).Value = vValue         End If      Next n      grd.MoveNext      m_lngExcelRow = m_lngExcelRow + 1   Next i   grd.MoveFirst   SetExcelCellWidthAutoFit   'Now write title if needed   If Not IsMissing(strTitle) Then      m_objWorksheet.Range("A1:Z1").Font.Bold = True      m_objWorksheet.Range("A1:Z1").Font.Color = vbBlack      m_objWorksheet.Range("A1:Z1").Font.Size = 18      m_objWorksheet.Range("A1") = strTitle      m_objWorksheet.Range("A2:Z2").Font.Bold = True      m_objWorksheet.Range("A2:Z2").Font.Color = vbBlack      m_objWorksheet.Range("A2:Z2").Font.Size = 10      m_objWorksheet.Range("A2") = "Run: " & Format$(Now, _          "mmmm dd, yyyy hh:mm AMPM")      m_objWorksheet.Range("A3:Z3").Font.Bold = True      m_objWorksheet.Range("A3:Z3").Font.Color = vbBlack      m_objWorksheet.Range("A3:Z3").Font.Size = 10      m_objWorksheet.Range("A3") = lngRows & " rows listed below "   End IfExitMe:   grd.redraw = True   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* ProperCase'* - Capitalizes the first character of the word and any character following an'*   underscore, hypen or space. All other characters will be lowercase'*--------------------------------------------------------------Private Function ProperCase(NewValue As String) As String   On Error GoTo ErrorHandler   Const constErrRoutine As String = "ProperCase"   Dim i As Integer   ProperCase = ""   'Capitalize the first character of the word and any character following an    ' underscore, hypen or space   'All other characters will be lowercase   For i = 1 To Len(NewValue)      If i = 1 Then         ProperCase = UCase(Mid$(NewValue, 1, 1))      Else         If Mid$(NewValue, i, 1) = "_" Or Mid$(NewValue, i, _             1) = " " Or Mid$(NewValue, i, 1) = "-" Then            ProperCase = ProperCase & Mid$(NewValue, i, 1)            i = i + 1            ProperCase = ProperCase & UCase(Mid$(NewValue, i, 1))         Else            ProperCase = ProperCase & LCase(Mid$(NewValue, i, 1))         End If      End If   Next iExitMe:   Exit FunctionErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Function'*--------------------------------------------------------------'* StoreExcelBlankRows'* - Skips line(s) in the excel file to produce blank rows'*--------------------------------------------------------------Public Sub StoreExcelBlankRows(NbrRows As Integer)   On Error GoTo ErrorHandler   Const constErrRoutine As String = "StoreExcelBlankRows"   Dim i    As Integer  If m_objWorksheet Is Nothing Then     Err.Raise 1000, "ttExcel.CreateExcelFromADORecordset", _         "You must first invoke the OpenExcelFile method before calling this " _         & "method."     GoTo ExitMe  End If   For i = 1 To NbrRows      Call StoreExcelRow(A:="  ")   Next iExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* SetExcelCellWidth'* - Sets the width of the excel cell(s).'*--------------------------------------------------------------Public Sub SetExcelCellWidth(Cell As String, Width As Single)   On Error GoTo ErrorHandler   Const constErrRoutine As String = "SetExcelCellWidth"   If m_objWorksheet Is Nothing Then      Err.Raise 1000, "ttExcel.CreateExcelFromADORecordset", _          "You must first invoke the OpenExcelFile method before calling this " _          & "method."      GoTo ExitMe   End If   With m_objWorksheet       .Cells.Columns(Cell).ColumnWidth = Width   End WithExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* SetExcelCellWidthAutoFit'* - Sets the width of the excel cell(s).'*--------------------------------------------------------------Public Sub SetExcelCellWidthAutoFit()   On Error GoTo ErrorHandler   Const constErrRoutine As String = "SetExcelCellWidthAutoFit"   If m_objWorksheet Is Nothing Then      Err.Raise 1000, "ttExcel.CreateExcelFromADORecordset", _          "You must first invoke the OpenExcelFile method before calling this " _          & "method."      GoTo ExitMe   End If   m_objWorksheet.Columns("A:Z").AutoFit   m_objWorksheet.Range("A1", "Z" & m_lngExcelRow).Rows.AutoFitExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* WrapText'* - Wraps the text of a set of columns'*--------------------------------------------------------------Public Sub WrapText(BeginCell As String, EndCell As String)   m_objWorksheet.Range(BeginCell & "1", EndCell & m_lngExcelRow).WrapText = _       TrueEnd Sub'*--------------------------------------------------------------'* AutoFitRows'* - Autofits the text of a set of columns'*--------------------------------------------------------------Public Sub AutoFitRows(BeginCell As String, EndCell As String)   m_objWorksheet.Range(BeginCell & "1", EndCell & m_lngExcelRow).Rows.AutoFitEnd Sub'*--------------------------------------------------------------'* AutoFitColumns'* - Autofits the text of a set of columns'*--------------------------------------------------------------Public Sub AutoFitColumns(BeginCell As String, EndCell As String)   m_objWorksheet.Columns(BeginCell & ":" & EndCell).AutoFitEnd Sub'*--------------------------------------------------------------'* CreateBorder'* - Sets the width of the excel cell(s).'*--------------------------------------------------------------Public Sub CreateBorder(Cell1 As String, Cell2 As Single)   On Error GoTo ErrorHandler   Const constErrRoutine As String = "CreateBorder"   If m_objWorksheet Is Nothing Then      Err.Raise 1000, "ttExcel.CreateExcelFromADORecordset", _          "You must first invoke the OpenExcelFile method before calling this " _          & "method."      GoTo ExitMe   End If   With m_objWorksheet       .Range(Cell1, Cell2).BorderAround   End WithExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* CreateBorder'* - Sets the width of the excel cell(s).'*--------------------------------------------------------------Public Sub CreateBorderHeader(Cell1 As String, Cell2 As Single, _    Optional FontColor As Variant)   On Error GoTo ErrorHandler   Const constErrRoutine As String = "CreateBorder"   If IsMissing(FontColor) Then      FontColor = &H800000          'Dark Blue   End If   If m_objWorksheet Is Nothing Then      Err.Raise 1000, "ttExcel.CreateExcelFromADORecordset", _          "You must first invoke the OpenExcelFile method before calling this " _          & "method."      GoTo ExitMe   End If   With m_objWorksheet       .Range(Cell1, Cell2).BorderAround Color:=FontColor       .Range(Cell1, Cell2).Font.Color = vbWhite   End WithExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* OpenExcelFile'* -  Returns a fully qualified Excel file name based on the export_path in the'*    INI file.  Deletes existing file if applicable.'*--------------------------------------------------------------Public Sub OpenExcelFile(FileName As String, Optional WorkSheetName As String = _    "", Optional AppendDayofWk As Boolean = False, Optional PageOrientation As _    XlPageOrientation = xlLandscape)   On Error GoTo ErrorHandler   Const constErrRoutine As String = "OpenExcelFile"   Dim sReturnString     As String   Dim lRc               As Long   m_strExcelFileName = FileName   If WorkSheetName = "" Then      WorkSheetName = "Sheet1"   End If   'Append the day of the week to the file name if necessary...   If AppendDayofWk Then      If Right$(m_strExcelFileName, 4) = ".xls" Then         m_strExcelFileName = Left$(m_strExcelFileName, _             Len(m_strExcelFileName) - 4) & Format$(Now, "dd") & ".xls"      Else         m_strExcelFileName = Left$(m_strExcelFileName, _             Len(m_strExcelFileName)) & Format$(Now, "dd") & ".xls"      End If   End If   If Right$(m_strExcelFileName, 4) <> ".xls" Then      m_strExcelFileName = m_strExcelFileName & ".xls"   End If   If Exists(m_strExcelFileName) Then      Kill m_strExcelFileName   End If   Set m_objXL = New Excel.Application   Set m_objWorkbook = m_objXL.Workbooks.Add   Set m_objWorksheet = m_objWorkbook.ActiveSheet   m_objWorksheet.Activate   'Set the worksheet name   m_objWorksheet.Name = WorkSheetName   'Set the orientation and scaling   Set m_objPageSetup = m_objWorksheet.PageSetup   With m_objPageSetup      Select Case PageOrientation         Case xlPortrait:  .Orientation = xlPortrait         Case Else:        .Orientation = xlLandscape      End Select      m_lxPageOrientation = .Orientation      .Zoom = False      .FitToPagesWide = 1      .FitToPagesTall = 100  'Set this high so that it will print 1 page wide   End WithExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* OpenExcelFileWithNoWorksheets'* - Returns a fully qualified Excel file name based on the export_path in the'*   INI file.  Deletes existing file if applicable.'*--------------------------------------------------------------Public Sub OpenExcelFileWithNoWorksheets(FileName As String, _    Optional PageOrientation As XlPageOrientation = xlLandscape)   On Error GoTo ErrorHandler   Const constErrRoutine As String = "OpenExcelFileWithNoWorksheets"   Dim sReturnString     As String   Dim lRc               As Long   Dim i As Integer   m_strExcelFileName = FileName   m_lxPageOrientation = PageOrientation   If Right$(m_strExcelFileName, 4) <> ".xls" Then      m_strExcelFileName = m_strExcelFileName & ".xls"   End If   If Exists(m_strExcelFileName) Then      Kill m_strExcelFileName   End If   Set m_objXL = CreateObject("Excel.Application")   Set m_objWorkbook = m_objXL.Workbooks.AddExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* AddNewWorkSheet'* - Creates a new worksheet'*--------------------------------------------------------------Public Sub AddNewWorksheet(WorkSheetName As String)   Set m_objWorksheet = m_objXL.Worksheets.Add   m_objWorksheet.Name = WorkSheetName   m_objWorksheet.Activate   'Set the orientation and scaling   Set m_objPageSetup = m_objWorksheet.PageSetup   With m_objPageSetup      Select Case m_lxPageOrientation         Case xlPortrait:  .Orientation = xlPortrait         Case Else:        .Orientation = xlLandscape      End Select      .Zoom = False      .FitToPagesWide = 1      .FitToPagesTall = 100  'Set this high so that it will print 1 page wide   End With   m_lngExcelRow = 0End Sub'*--------------------------------------------------------------'* CloseExcelFile'* - Closes the Excel file that was previously opened and clears memory.'*--------------------------------------------------------------Public Sub CloseExcelFile()   On Error GoTo ErrorHandler   Const constErrRoutine As String = "CloseExcelFile"   If m_objWorksheet Is Nothing Then      Err.Raise 1000, "ttExcel.CreateExcelFromADORecordset", _          "You must first invoke the OpenExcelFile method before calling this " _          & "method."      GoTo ExitMe   End If   Call StoreExcelRow(A:=" ")   m_objWorkbook.SaveAs m_strExcelFileName   m_objWorkbook.Close SaveChanges:=False   m_objXL.Quit   Set m_objWorksheet = Nothing   Set m_objWorkbook = Nothing   Set m_objXL = NothingExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description   Resume ExitMeEnd Sub'*--------------------------------------------------------------'* Exists'* - Determines if a file exists. Returns true or false'* - Example      : blnDoesItExist = Exists("C:CONFIG.SYS")'*--------------------------------------------------------------Private Function Exists(FileName) As Integer  Dim lFileLen    As Long  On Error Resume Next  lFileLen = FileLen(FileName)  If lFileLen > 0 Then    Exists = True  End IfEnd Function'*--------------------------------------------------------------'* Class_Terminate'* -  Close the excel file and cleanup if they forget to.'*--------------------------------------------------------------Private Sub Class_Terminate()   If m_objXL Is Nothing Then      'Cool, get out   Else      'They forgot to close the file      CloseExcelFile   End IfEnd Sub'*--------------------------------------------------------------'* ReadValue'* -  Reads a value from the Excel worksheet based on a previously defined label'*--------------------------------------------------------------Public Sub ReadValue(Label As String, ByRef Value As String)   On Error Resume Next   Value = m_objXL.Range(Label).Value   If Err.Number = 0 Then      ' It worked, just return   Else      If Err.Number = m_lngExcelLabelNotFound Then         Value = ""      Else         Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, _             Err.HelpContext      End If   End IfEnd Sub'###########################################################'#'#   This class has been brought to you by Pragmatic Software Co. Inc,'#   the creators of Defect Tracker, the tool of choice for tracking'#   functional specifications, test cases and software bugs.'#   Learn more at http://www.DefectTracker.com.'#   Affiliate program also available at  '#          http://www.PragmaticSW.com/AffiliateSignup.'#'###########################################################