MSExcel – A class for writing Excel spreadsheets

'***********************************************************'* 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.'#'###########################################################

Share the Post:
Share on facebook
Share on twitter
Share on linkedin

Overview

The Latest

your company's audio

4 Areas of Your Company Where Your Audio Really Matters

Your company probably relies on audio more than you realize. Whether you’re creating a spoken text message to a colleague or giving a speech, you want your audio to shine. Otherwise, you could cause avoidable friction points and potentially hurt your brand reputation. For example, let’s say you create a

chrome os developer mode

How to Turn on Chrome OS Developer Mode

Google’s Chrome OS is a popular operating system that is widely used on Chromebooks and other devices. While it is designed to be simple and user-friendly, there are times when users may want to access additional features and functionality. One way to do this is by turning on Chrome OS

homes in the real estate industry

Exploring the Latest Tech Trends Impacting the Real Estate Industry

The real estate industry is changing thanks to the newest technological advancements. These new developments — from blockchain and AI to virtual reality and 3D printing — are poised to change how we buy and sell homes. Real estate brokers, buyers, sellers, wholesale real estate professionals, fix and flippers, and beyond may