Attribute VB_Name = "modAccessExportToExcel" Option Compare Database Option Explicit '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Source: www.consultdmw.com ' Copyright: DMW Consultancy Limited, Tonbridge, UK, (t) +44(0)1732833085 ' Terms: For private use only. Not for professional or commercial use ' without contribution to, and express approval of, ' DMW Consultancy Limited '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function dmwExportToXL(query$, _ fileName$, wksName$, _ colsCurrency$, colsDate$) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ On Error GoTo errHandler Dim bln As Boolean Dim path$ Dim msg$ path$ = Left(CurrentProject.FullName, _ InStrRev(CurrentProject.FullName, "\")) path$ = path$ & "KEY.ini" path$ = dmwGetPathFromKEY(path$, "ExportPath") Select Case path$ Case "Error" msg$ = "Unanticipated error locating KEY" bln = False Case Else bln = True End Select If bln Then msg$ = dmwCheckPath(path$) If msg$ = vbNullString Then msg$ = dmwExport( _ query$, path$, _ fileName$, wksName$, _ colsCurrency$, colsDate$) Else msg$ = _ "Folder for exports cannot be located. " & msg$ End If procDone: If msg$ <> vbNullString Then MsgBox msg$, vbExclamation, "Excel Export" End If Exit Function errHandler: msg$ = Err.Number & ": " & Err.Description Resume procDone End Function Function dmwGetPathFromKEY(pathINI$, element$) As String '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ On Error GoTo errHandler Dim i&, lenElement& Dim fstChar34%, lstChar34% Dim lineINI$, path$ If Len(Dir(pathINI$)) > 0 And Len(element$) > 0 Then lenElement& = Len(element$) i& = FreeFile() Open pathINI$ For Input As #i& Do While Not EOF(i&) Line Input #i&, lineINI$ If Left(lineINI$, lenElement&) = element$ Then path$ = Mid(lineINI$, lenElement& + 1) Exit Do End If Loop Close #i& fstChar34% = InStr(path$, Chr(34)) + 1 lstChar34% = InStrRev(path$, Chr(34)) path$ = Mid(path$, fstChar34%, lstChar34% - fstChar34%) Else path$ = "Error" End If procDone: dmwGetPathFromKEY = path$ Exit Function errHandler: path$ = "Error" Resume procDone End Function Function dmwCheckPath(path$) As String '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ On Error GoTo errHandler Dim msg$ If Dir(path$, vbDirectory) = "." Then msg$ = vbNullString Else msg$ = _ "No folder matches entry in KEY file" End If procDone: dmwCheckPath = msg$ Exit Function errHandler: msg$ = Err.Description Resume procDone End Function Function dmwExport( _ query$, path$, _ fileName$, wksName$, _ colsCurrency$, colsDate$ _ ) As String '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ On Error GoTo errHandler Dim xlApp As Object, wkbk As Object, wks As Object Dim file$ Dim formatCur$, formatDate$, intColor& Dim arrayCols() As String, col$, n%, i%, w! Dim cell As Range Dim msg$ ' Worksheet formats formatCur$ = "£#,##0.00" formatDate$ = "yyyy-mm-dd" intColor& = RGB(100, 200, 200) ' Create workbook file$ = path$ & fileName$ DoCmd.TransferSpreadsheet _ TransferType:=acExport, _ SpreadsheetType:=acSpreadsheetTypeExcel12Xml, _ TableName:=query$, _ fileName:=file$, _ HasFieldNames:=True ' Open workbook Set xlApp = CreateObject("Excel.Application") With xlApp .Visible = True Set wkbk = .Workbooks.Open(file$) End With ' Format worksheet Set wks = wkbk.worksheets(1) With wks .Name = wksName$ ' Currency columns arrayCols = Split(colsCurrency$, ",") For i = LBound(arrayCols) To UBound(arrayCols) With .Columns(arrayCols(i)) .NumberFormat = formatCur$ End With Next i ' Date columns arrayCols = Split(colsDate$, ",") For i = LBound(arrayCols) To UBound(arrayCols) With .Columns(arrayCols(i)) .NumberFormat = formatDate$ End With Next i ' Filters With .Range("A1") .Select .autofilter End With ' Column width adjustments With .Cells .Select .EntireColumn.AutoFit End With n% = .Cells(1, 1).End(xlToRight).Column For i% = 1 To n% With .Cells(1, i%) w! = .EntireColumn.ColumnWidth .EntireColumn.ColumnWidth = w! + 4 .HorizontalAlignment = xlCenter .Interior.Color = intColor& .Font.Bold = True End With Next i% End With With xlApp.ActiveWindow .SplitColumn = 0 .SplitRow = 1 .FreezePanes = True End With msg$ = vbNullString procDone: Set wks = Nothing Set wkbk = Nothing Set xlApp = Nothing dmwExport = msg$ Exit Function errHandler: msg$ = _ Err.Number & ": " & Err.Description Resume procDone End Function