Private m_objExcel As Excel.Application
Private m_objWorkbook As Excel.Workbook
Public Property Get AppExcel() As Excel.Application
' Returns: A handle to the current instance of Excel
Set AppExcel = m_objExcel
End Property
Public Property Get CurWorkbook() As Excel.Workbook
' Returns: A handle to the currently open workbook
Set CurWorkbook = m_objWorkbook
End Property
Public Sub CloseExcel()
' Comments : Closes Excel
' Parameters: None
' Returns : Nothing
'
On Error GoTo PROC_ERR
m_objExcel.Quit
Set m_objExcel = Nothing
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"CloseExcel"
Resume PROC_EXIT
End Sub
Public Sub CloseWorkbook( _
fSave As Boolean)
' Comments : Closes the current workbook
' Parameters: fSave - True to save changes, False to discard changes
' Returns : Nothing
'
On Error GoTo PROC_ERR
m_objWorkbook.Close SaveChanges:=fSave
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"CloseWorkbook"
Resume PROC_EXIT
End Sub
Public Sub CreateTableFromAccess( _
strDatabase As String, _
strDataSource As String, _
fFieldNames As Boolean, _
Optional varMaxRecs As Variant)
' Comments : Gets the contents of an Access table or query into
' the current document
' Parameters: strDatabse - full path and name of the Access database
' you want to read from
' strDataSource - name of a table or query in the database
' to read records from
' fFieldNames - True to put the field names in the first
' row, false otherwise.
' varMaxRecs - optional: set to the maximum number of
' records you want to retrieve. To include all records,
' don't specify this argument.
' Returns : Nothing
'
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim intCounter As Integer
Dim intFieldCount As Integer
Dim lngRowCount As Long
Dim varField As Variant
Dim intRow As Integer
Dim intCol As Integer
On Error GoTo PROC_ERR
' Open the database objects
Set dbs = DAO.DBEngine.OpenDatabase(strDatabase)
Set rst = dbs.OpenRecordset(strDataSource)
intFieldCount = rst.Fields.Count
intRow = 1
intCol = 1
' Add the field names if specified
If fFieldNames Then
For intCounter = 1 To intFieldCount
m_objWorkbook.ActiveSheet.Cells(1, intCounter).Value = _
rst.Fields(intCounter - 1).Name
Next intCounter
End If
' Start inserting data on the second row of the table
lngRowCount = 2
With rst
' Loop through all records
Do Until .EOF
For intCounter = 1 To intFieldCount
' Add each fields value
varField = .Fields(intCounter - 1).Value
' Handle null field values
If IsNull(varField) Then
varField = "
End If
m_objWorkbook.ActiveSheet.Cells(lngRowCount, intCounter).Value = _
varField
Next intCounter
lngRowCount = lngRowCount + 1
' See if we are still in range
If Not IsMissing(varMaxRecs) Then
If lngRowCount > varMaxRecs Then
Exit Do
End If
End If
' Move to the next record
.MoveNext
Loop
End With
' Cleanup
rst.Close
dbs.Close
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"CreateTableFromAccess"
Resume PROC_EXIT
End Sub
Public Sub CreateWorkbook( _
strName As String, _
fSave As Boolean)
' Comments : Creates a new workbook and saves it
' Parameters: strName - name for the new workbook
' fSave - True to save, False to leave unsaved
' Returns : Nothing
'
On Error GoTo PROC_ERR
Set m_objWorkbook = m_objExcel.Workbooks.Add
m_objWorkbook.SaveAs filename:=strName
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"CreateWorkbook"
Resume PROC_EXIT
End Sub
Public Sub InsertValue( _
strRange As String, _
varValue As Variant)
' Comments : Inserts values into cells
' Parameters: strRange - string defining the range to insert into
' varValue - value to insert
' Returns : Nothing
'
On Error GoTo PROC_ERR
m_objWorkbook.ActiveSheet.Range(strRange).Value = varValue
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"InsertValue"
Resume PROC_EXIT
End Sub
Public Sub OpenWorkbook( _
strFileName As String, _
fReadOnly As Boolean, _
Optional varPassword As Variant)
' Comments : Opens the named file and associates it with the class
' Parameters: strFileName - full path and name of the file to open
' fReadOnly - True to open readonly
' varPassword - Optional: specify the password if the
' workbook file is password protected.
' Returns : Nothing
'
On Error GoTo PROC_ERR
If Not IsMissing(varPassword) Then
Set m_objWorkbook = m_objExcel.Workbooks.Open( _
strFileName, _
, _
fReadOnly, _
, _
varPassword)
Else
Set m_objWorkbook = m_objExcel.Workbooks.Open( _
strFileName, _
, _
fReadOnly)
End If
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"OpenWorkbook"
Resume PROC_EXIT
End Sub
Public Sub OpenWorkbookFromLib( _
strFileName As String, _
fReadOnly As Boolean, _
Optional varPassword As Variant)
' Comments : Opens the named file and associates it with the class.
' This version looks in the Excel library folder.
' Parameters: strFileName - name of the file to open
' fReadOnly - True to open readonly
' varPassword - Optional: specify the password if the
' workbook file is password protected.
' Returns : Nothing
'
Dim strLibPath As String
On Error GoTo PROC_ERR
strLibPath = m_objExcel.LibraryPath & _
m_objExcel.PathSeparator & _
strFileName
If Not IsMissing(varPassword) Then
Set m_objWorkbook = m_objExcel.Workbooks.Open( _
strLibPath, _
, _
fReadOnly, _
, _
varPassword)
Else
Set m_objWorkbook = m_objExcel.Workbooks.Open( _
strLibPath, _
, _
fReadOnly)
End If
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"OpenWorkbookFromLib"
Resume PROC_EXIT
End Sub
Public Sub PrintSheet( _
intFrom As Integer, _
intTo As Integer, _
intCopies As Integer, _
fPreview As Boolean, _
fPrintToFile As Boolean, _
fCollate As Boolean)
' Comments : Prints the active workbook
' Parameters: intFrom - starting page number
' intTo - ending page number
' intCopies - number of copies
' fPreview - True for print preview
' fPrintToFile - True to print to a file. Excel will prompt
' for the filename when this is set to True.
' fCollate - True to collate copies
' Returns : Nothing
'
On Error GoTo PROC_ERR
m_objWorkbook.PrintOut _
intFrom, _
intTo, _
intCopies, _
fPreview, _
, _
fPrintToFile, _
fCollate
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"PrintSheet"
Resume PROC_EXIT
End Sub
Public Sub SortRange( _
strRange As String, _
strKey As String, _
Optional fAscending As Boolean = False)
' Comments : Sorts the specified range
' Parameters: strRange - range to sort
' strKey - range to use as the key for sorting
' fAscending - True for ascending, False for descending
' Returns : Nothing
'
Dim lngSort As Integer
If fAscending Then
lngSort = xlAscending
Else
lngSort = xlDescending
End If
m_objWorkbook.ActiveSheet.Range(strRange).Sort _
Key1:=ActiveSheet.Range(strKey), order1:=lngSort
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"SortRange"
Resume PROC_EXIT
End Sub
Public Sub StartExcel(fVisible As Boolean)
' Comments : Starts an instance of Excel
' Parameters: fVisible - True to make Excel visible
' Returns : Nothing
On Error GoTo PROC_ERR
Set m_objExcel = New Excel.Application
m_objExcel.Visible = fVisible
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"StartExcel"
Resume PROC_EXIT
End Sub