Option Compare Database
Public Function CreateTQExcelWB(strWBName As String) As Boolean
On Error GoTo err_handler
CreateTQExcelWB = True
strWBName = "H:\TRS\" & strWBName
Set appExcel = Excel.Application
If Dir(strWBName & ".xls") <> "" Then
SetAttr strWBName & ".xls", vbNormal
Kill strWBName & ".xls"
End If
Set Wbk = appExcel.Workbooks.Add
' **** save the new workbook with the strWBName path/filename
Wbk.SaveAs strWBName
Set wks = Wbk.Worksheets("Sheet1")
Set wks = Nothing
Wbk.Save
Wbk.Close
Set Wbk = Nothing
exit_routine:
appExcel.Quit
Set appExcel = Nothing
Exit Function
err_handler:
Dim Errorcode As Integer
Errorcode = MsgBox("Error: " & Err.Description, vbOKCancel, "Error")
If Errorcode = vbOK Then
CreateTQExcelWB = False
Resume exit_routine
Else
Resume
End If
End Function
Public Function SendTQ2ExcelSheet(strTQName As String, strSheetName As String, strPath As String) As Boolean
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to
Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As DAO.Field
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
SendTQ2ExcelSheet = True
On Error GoTo err_handle
Set rst = CurrentDb.OpenRecordset(strTQName)
Set ApXL = CreateObject("Excel.Application")
Set xlWBk = ApXL.Workbooks.Open(strPath)
ApXL.Visible = True
Set xlWSh = xlWBk.Worksheets.Add
xlWSh.Name = strSheetName
xlWSh.Activate
xlWSh.Range("A1").Select
For Each fld In rst.Fields
ApXL.ActiveCell = fld.Name
ApXL.ActiveCell.Offset(0, 1).Select
Next
rst.MoveFirst
xlWSh.Range("A2").CopyFromRecordset rst
xlWSh.Range("1:1").Select
With ApXL.Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
ApXL.Selection.Font.Bold = True
With ApXL.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
' selects all of the cells
ApXL.ActiveSheet.Cells.Select
' does the "autofit" for all columns
ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
' selects the first cell to unselect all cells
xlWSh.Range("A1").Select
rst.Close
Set rst = Nothing
xlWBk.Save
xlWBk.Close
ApXL.Quit
Exit Function
err_handle:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
SendTQ2ExcelSheet = False
ApXL.DisplayAlerts = False
ApXL.Quit
Exit Function
End Function
Public Function DeleteTQExcelWBk(strPath As String) As Boolean
On Error GoTo err_Handling
Dim appExcel As Object
Dim Wbk As Object
Dim WSh As Object
DeleteTQExcelWBk = True
Set appExcel = Excel.Application
Set Wbk = appExcel.Workbooks.Open(strPath)
appExcel.Visible = True
appExcel.DisplayAlerts = False
appExcel.Sheets("Sheet1").Select
appExcel.ActiveSheet.Delete
appExcel.Sheets("Sheet3").Select
appExcel.ActiveSheet.Delete
appExcel.Sheets("Sheet2").Select
appExcel.ActiveSheet.Delete
Wbk.Save
Wbk.Close
appExcel.Quit
Exit Function
err_Handling:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
DeleteTQExcelWBk = False
appExcel.DisplayAlerts = False
appExcel.Quit
Exit Function
End Function
