Trouble with File Dialog

[aimeepeter]

This was working fine before so I am not sure what has happened. I have a command button which creates a formatted Excel spreadsheet from one of my queries.

I am getting Error 445 (Object doesn't support this action) when I try to open a Save As dialog box and have the user specify a file name and path. The debugger points to this line:
With Application.FileDialog(msoFileDialogSaveAs)

Here is the full code:

'Define Variables
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlWorkbook As Excel.Workbook
Dim objRST As Recordset
Dim strQueryName As String
Dim strSheetName As String
Dim strFilePath As String
Dim strShowCity As String
Dim strShowType As String
Dim strShowSeason As String
Dim strShowYear As String
strShowCity = DLookup("ShowCity", "qryPaperworkSet1")
strShowType = DLookup("ShowType", "qryPaperworkSet1")
strShowSeason = DLookup("ShowSeason", "qryPaperworkSet1")
strShowYear = DLookup("ShowYear", "qryPaperworkSet1")

DoCmd.Hourglass True

'Use the FileDialog to choose the file location
With Application.FileDialog(msoFileDialogSaveAs)
.Title = "Save As"
.AllowMultiSelect = False

'Show the dialog and if the dialog returns
'True, then create the new Spreadsheet
If .Show = True Then 'The user clicked "Save"
strFilePath = .SelectedItems(1)
Else 'The user canceled the dialog so exit
MsgBox "Save As canceled! Artists By Store Schedule has not been saved."
Exit Sub
End If
End With

'Check to see if the file already exists
If (Dir$(strFilePath) <> "") Then
'Delete the file since it already exists
Kill strFilePath
End If

'Create the Excel Application object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'Create a new workbook
Set xlWorkbook = xlApp.Workbooks.Add
'Specify the Recordset
strQueryName = "qryPS1RetailSchedule"

Set objRST = Application.CurrentDb.OpenRecordset(strQueryName)

With objRST
.MoveLast
.MoveFirst
If IsNull(.RecordCount) Then
MsgBox "There are no records in this schedule. Cannot create schedule.", vbCritical, gstrAppTitle
Exit Sub
End If
End With

'Create a Sheet Name - Must be 31 chars or less
strSheetName = Trim(Left("Retail Schedule" & strShowCity & " " & strShowType & " " & strShowSeason & strShowYear, 31))
'Add headings to each of the columns
Set xlSheet = xlWorkbook.Sheets(1)
For lvlColumn = 0 To objRST.Fields.Count - 1
xlSheet.Cells(1, lvlColumn + 1).Value = _
objRST.Fields(lvlColumn).Name
Next
'Change the font to bold for the header row
xlSheet.Range(xlSheet.Cells(1, 1), _
xlSheet.Cells(1, objRST.Fields.Count)).Font.Bold = True
'Add a border on the left of the header row cells
With xlSheet.Range(xlSheet.Cells(1, 1), _
xlSheet.Cells(1, objRST.Fields.Count)).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Add a border on the top of the header row cells
With xlSheet.Range(xlSheet.Cells(1, 1), _
xlSheet.Cells(1, objRST.Fields.Count)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Add a border on the bottom of the header row cells
With xlSheet.Range(xlSheet.Cells(1, 1), _
xlSheet.Cells(1, objRST.Fields.Count)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Add a border on the right of the header row cells
With xlSheet.Range(xlSheet.Cells(1, 1), _
xlSheet.Cells(1, objRST.Fields.Count)).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Copy the data into the spreadsheet, starting on the 2nd cell
With xlSheet
.Range("A2").CopyFromRecordset objRST
.Name = Left(strQueryName, 31)
End With
xlSheet.Columns("D: D").Select
xlApp.Selection.NumberFormat = "[$-409]d-mmm-yy;@"

xlSheet.Columns("A:K").Select
xlSheet.Columns("A:K").EntireColumn.AutoFit

'Determine shading colour based on city name
'default is plum colour
strShowCity = DLookup("ShowCity", "qryPaperworkSet1")
If strShowCity = "Milan" Then
xlSheet.Rows("1:1").Select
With xlApp.Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf strShowCity = "Paris" Then
xlSheet.Rows("1:1").Select
With xlApp.Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Else
xlSheet.Rows("1:1").Select
With xlApp.Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End If

xlSheet.SaveAs FileName:=strFilePath
'Cleanup Variables
Set xlSheet = Nothing
Set xlWorkbook = Nothing
Set xlApp = Nothing

objRST.Close
Set objRST = Nothing
DoCmd.Hourglass False
Exit_Procedure:
Set objRST = Nothing
DoCmd.Hourglass False
Exit Sub

Error_Handler:
If Err.Number = 70 Then
MsgBox "This document is already open. Excel cannot save a document with the same name as an open document. Cancelling operation.", vbCritical, gstrAppTitle
Else
MsgBox "An error has occurred in this database. Please contact your database designer and tell them this information: " _
& vbCrLf & vbCrLf & "Error Number " & Err.Number & ", " & Err.Description, vbCritical
End If
Resume Exit_Procedure
Resume
End Sub

 

[Rabbie]

It is much easier to read your code if you enclose it in code tags( code enclosed in square brackets and terminated with /code in square brackets)

 

[CyberLynx]

Make sure the Microsoft Office xx.x Object Library is Referenced from within the VBA IDE. If it is and it's at the bottom of the Checked Marked Reference List then step it up by one.

.