Option Compare Database
Option Explicit
Const xlLandscape As Long = 2
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
Const xlContext As Integer = -5002
Const xlDown As Integer = -4121
Const xlContinuous As Integer = 1
Const xlThin As Integer = 2
Const xlLastCell As Long = 11
Const xlYes As Long = 1
Const xlSrcRange As Long = 1
Const xlMaximized As Integer = -4137 ' Maximized
Const xlMinimized As Integer = -4140 ' Minimized
Const xlNormal As Integer = -4143 ' Normal
Public bOverWrite As Boolean
Public bOpenFile As Boolean
Global glDb As DAO.Database
'Report handling all queries / report selecting moved to one module for simplicity
Public Sub ListReporter(qryName As String, qrySaveName As String, XLExport As Integer)
Dim txtQueryName As String
Dim strSaveFile As String
Dim sSql As String
Dim sComputerName As String
Dim iResp As Integer
Dim sRange As String
Dim sUser As String
On Error GoTo ListReporter_Error
bOpenFile = True
If glDb Is Nothing Then Set glDb = CurrentDb
txtQueryName = Left(Replace(qryName, " ", "_"), 30) 'Remove any spaces as spaces in the sheet name cause issues.
strSaveFile = (Application.CurrentProject.Path & "\" & qrySaveName & "_" & Format(Date, "yyyymmdd")) & ".xlsx"
If Not XLExport Then
DoCmd.OpenQuery qryName, acViewNormal, acReadOnly
Else
If IsFileOpen(strSaveFile) Then
MsgBox "The file " & strSaveFile & " is currently open." & vbCrLf & "Please close it before trying to overwrite it!!", vbInformation, "File Open!"
Exit Sub
End If
If FileExists(strSaveFile) Then
If bOverWrite Then
Kill strSaveFile
Else
iResp = MsgBox("This file is already saved, do you want to delete it first? " & vbCrLf & _
"Selecting no will retain any formatting, but may result in an error if you have any summary or total fields added to the existing version", vbYesNo, "File Exists!")
If iResp = vbYes Then
Kill strSaveFile
End If
End If
End If
sRange = txtQueryName
DoCmd.TransferSpreadsheet acExport, 10, qryName, strSaveFile, True, sRange, True
'Debug.Print "here1"
If Not bOpenFile Then
Call XLFormatTable(strSaveFile, txtQueryName, False)
Else
If MsgBox("Your file has been saved in the c:\ExcelSaves folder, do you want to open it ?", vbYesNo, "Reports") = vbYes Then
Call XLFormatTable(strSaveFile, txtQueryName, True)
Else
Call XLFormatTable(strSaveFile, txtQueryName, False)
End If
End If
End If
On Error GoTo 0
Exit Sub
ListReporter_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ListReporter of ReportLogger"
End Sub
Public Sub XLFormatTable(sFile As String, sSheet As String, Optional bOpen As Boolean = True)
On Error GoTo XLFormatTable_Error
' Late binding to avoid reference:
Dim xlApp As Object 'Excel.Application
Dim xlWb As Object 'Workbook
Dim xlWS As Object 'Worksheet
Dim tbl As Object
Dim rng As Object
'Debug.Print sFile, sSheet
' Create the instance of Excel that we will use to open the temp book
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = bOpen
Set xlWb = xlApp.Workbooks.Open(sFile)
'Debug.Print xlWB.Name
Set xlWS = xlWb.Worksheets(sSheet)
' Format our temp sheet
' ************************************************** *************************
xlApp.Range("A1").Select
With xlWS
' With .UsedRange
' .borders.LineStyle = xlContinuous
' .borders.ColorIndex = 0
' .borders.TintAndShade = 0
' .borders.Weight = xlThin
' End With
'
' 'format header 90 degree
' With .Range("i1:y1")
' .HorizontalAlignment = xlCenter
' .VerticalAlignment = xlBottom
' .WrapText = False
' .Orientation = 90
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = False
' End With
' .UsedRange.Rows.RowHeight = 15
' .UsedRange.Columns.AutoFit
With xlWb.Sheets(sSheet)
Set rng = .Cells(1, 1).CurrentRegion
End With
Set tbl = xlWS.ListObjects.Add(xlSrcRange, rng, , xlYes)
tbl.TableStyle = "TableStyleMedium2"
tbl.ShowTotals = False
xlWS.Cells.EntireColumn.AutoFit
End With
xlWb.Save
If Not bOpen Then
xlApp.Workbooks.Close
Set xlApp = Nothing
Else
xlApp.ActiveWindow.WindowState = xlMaximized
End If
On Error GoTo 0
Exit Sub
XLFormatTable_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure XLFormatTable, line " & Erl & "."
End Sub
Function IsFileOpen(fileName As String)
Dim filenum As Integer, errnum As Integer
'Firstly check there is a file to check ;)
If Not FileExists(fileName) Then
IsFileOpen = False 'doesn't exist so therefore it can't be open
Exit Function
End If
On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open fileName For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error errnum
End Select
End Function
Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
'Purpose: Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if no path included.
' bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
'Note: Does not look inside subdirectories for the file.
'Author: Allen Browne. http://allenbrowne.com June, 2006.
Dim lngAttributes As Long
'Include read-only files, hidden files, system files.
lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)
If bFindFolders Then
lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
Else
'Strip any trailing slash, so Dir does not look inside the folder.
Do While Right$(strFile, 1) = "\"
strFile = Left$(strFile, Len(strFile) - 1)
Loop
End If
'If Dir() returns something, the file exists.
On Error Resume Next
FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function