Sure, it's my first try at this, but I got some good examples from this
group. Here it is:
Function convert_files() As Boolean
'On Error Resume Next
DoCmd.SetWarnings False
Dim appexcel As Object
Set appexcel = CreateObject("Excel.application")
appexcel.Application.Visible = False
appexcel.Application.UserControl = False
appexcel.DisplayAlerts = True
appexcel.Interactive = False
appexcel.ScreenUpdating = False
Dim appbook As Object
Dim appsheet As Object
Dim fs, f, f1, fc, s, wk, firsttime, tn, fn, qt, ch
Dim mindate, maxdata As Date
Let firsttime = True
Let qt = "Query_template"
Set fs = CreateObject("Scripting.FileSystemObject")
'
' clear archive directory
'
fs.deletefile "C:\KH\Archived\*.csv", True
'
' setup directory search for csv files
'
Set f = fs.GetFolder("C:\KH")
Set fc = f.Files
For Each f1 In fc
If Right(f1.Name, 3) = "csv" Then
'
' create xls file name from csv file namefrom template to create
xls file
'
Let tn = Mid(f1.Name, 4, 3) & Mid(f1.Name, 8, 4)
Let wk = "C:\KH\LD_" & tn & Format(f1.DateCreated, "yyyymmdd") &
".xls"
'
' create a work table from the table template 1 time
'
If firsttime = True Then
DoCmd.CopyObject , "work_table", acTable, "table_template"
Let firsttime = False
End If
'
' load the work table from the csv file
'
Let fn = "C:\KH\" & f1.Name
DoCmd.TransferText acImportDelim, "KH Import Specification",
"work_table", fn, True
'
' export the work table to the xls file using the copy of the
query template
'
DoCmd.CopyObject , tn, acQuery, qt
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, tn, wk,
True
DoCmd.DeleteObject acQuery, tn
'
' get the Min and Max check dates on the file
'
Let mindate = DMin("[check date]", "work_table")
Let maxdate = DMax("[check date]", "work_table")
' MsgBox maxdate
'
' open the xls file
'
Set appbook = appexcel.Workbooks.Open(wk)
Set appsheet = appbook.ActiveSheet
'
' for debugging
'
' x = appsheet.Name
' MsgBox x
' x = appsheet.Name
' MsgBox x
' freeze row 1 for display
appsheet.Activate
appsheet.Range("A2").Select
ActiveWindow.FreezePanes = True
'
' autosize row 1
'
With appsheet
For Each cell In appsheet.Range("A1", "O1")
cell.Font.Bold = True
Next
End With
With appsheet
.Columns("A:N").Font.Name = "Arial"
.Columns("A:N").Font.Size = 8
.Columns("A:N").EntireColumn.AutoFit
End With
With appsheet.PageSetup
.PrintTitleRows = appsheet.Rows(1).Address
.PrintTitleColumns = appsheet.Columns("A:O").Address
.Orientation = xlLandscape
.FitToPagesTall = False
.FitToPagesWide = 1
' .CenterHeader = "Labor Distribution " & Chr(10) & "for" &
Chr(10) & "&A"
.LeftHeader = "&B" & "Check Dates " & mindate & " to " & maxdate
& "&B"
.CenterHeader = "&B" & "Labor Distribution for " & "&A" & "&B"
.CenterFooter = "&F" & " " & "&D"
.RightFooter = "&R Page &P of &N"
.LeftMargin = appexcel.InchesToPoints(0)
.RightMargin = appexcel.InchesToPoints(0)
.TopMargin = appexcel.InchesToPoints(0.5)
.BottomMargin = appexcel.InchesToPoints(0.5)
.HeaderMargin = appexcel.InchesToPoints(0.25)
.FooterMargin = appexcel.InchesToPoints(0.25)
End With
appbook.Save
appbook.Close
Let fm = "C:\KH\archived\" & f1.Name
' s = s & fn
' s = s & vbCrLf
fs.movefile fn, fm
DoCmd.OpenQuery "erase_work_table"
End If
Next
' MsgBox s
DoCmd.DeleteObject acTable, "work_table"
appexcel.Quit
Set f = Nothing
Set fc = Nothing
Set fs = Nothing
Set appsheet = Nothing
Set appbk = Nothing
Set appexcel = Nothing
End Function
