dcsimg
Login | Register   
LinkedIn
Google+
Twitter
RSS Feed
Download our iPhone app
TODAY'S HEADLINES  |   ARTICLE ARCHIVE  |   FORUMS  |   TIP BANK
Browse DevX
Sign up for e-mail newsletters from DevX

By submitting your information, you agree that devx.com may send you DevX offers via email, phone and text message, as well as email offers about other products and services that DevX believes may be of interest to you. DevX will process your information in accordance with the Quinstreet Privacy Policy.


Tip of the Day
Language: VB5,VB6
Expertise: Intermediate
Jul 22, 2000

WEBINAR:

On-Demand

Building the Right Environment to Support AI, Machine Learning and Deep Learning


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 Text
Option Base 1                    'Start arrays at element 1 instead of 0

'Constants
Private Const m_constPgm As String = "MSExcel."
Private Const m_lngExcelLabelNotFound = 1004

'Objects
Private m_objWorkbook             As Workbook
Private m_objWorksheet            As Worksheet
Private m_objXL                   As Excel.Application
Private m_objPageSetup            As Excel.PageSetup
Private m_lxPageOrientation       As XlPageOrientation

'Strings
Private m_strExcelFileName          As String

'Longs
Private 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 If

ExitMe:
    Exit Sub

ErrorHandler:
    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 With

End 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.MoveFirst

ExitMe:
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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 If

ExitMe:
   grd.redraw = True
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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 i

ExitMe:
   Exit Function

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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 i

ExitMe:
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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 With

ExitMe:
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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.AutoFit

ExitMe:

   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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 = _
       True

End 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.AutoFit

End Sub

'*--------------------------------------------------------------
'* AutoFitColumns
'* - Autofits the text of a set of columns
'*--------------------------------------------------------------

Public Sub AutoFitColumns(BeginCell As String, EndCell As String)

   m_objWorksheet.Columns(BeginCell & ":" & EndCell).AutoFit

End 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 With

ExitMe:
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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 With

ExitMe:
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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 With

ExitMe:
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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.Add

ExitMe:
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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 = 0

End 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 = Nothing

ExitMe:
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constErrRoutine, Err.Description
   Resume ExitMe

End 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 If

End 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 If

End 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 If

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

Stevel Miller
 
Comment and Contribute

 

 

 

 

 


(Maximum characters: 1200). You have 1200 characters left.

 

 

Sitemap
Thanks for your registration, follow us on our social networks to keep up-to-date