从Access VBA保存Excel工作簿

Posted 2021-04-06

我正在从访问查询导出记录集到Excel工作簿。导出正常，我的语法会根据需要提示用户输入文件名/位置。但是，该文件实际上并未保存。我是否错过了流程中的一个步骤，或者需要进行哪些代码更改才能拥有此功能？

    Sub ETE()

    Dim ExcelApp As Object, wbOutput As Object, wsOutput As Object, bExcelOpened As Boolean
    Dim db As DAO.Database, rs As DAO.Recordset, targetRow As Long
    Dim targetPath As String, fd As FileDialog, Title As String, saveInfo As Variant

    DoCmd.Hourglass True

    Set ExcelApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo Error_Handler
        Set ExcelApp = CreateObject("Excel.Application")
        bExcelOpened = False
    Else
        bExcelOpened = True
    End If
    On Error GoTo Error_Handler
    ExcelApp.ScreenUpdating = False
    ExcelApp.Visible = False
    Set wbOutput = ExcelApp.Workbooks.Add()
    Set wsOutput = wbOutput.Sheets(1)
    Set db = CurrentDb
    Set rs = db.OpenRecordset("qryTakeDataToExcel", dbOpenSnapshot)

    With rs
        If .RecordCount <> 0 Then
            'Write the data to Excel
        End If
    End With
    Set fd = Application.FileDialog(msoFileDialogSaveAs)

    With fd
        .AllowMultiSelect = False
        .Title = "Select Save Location And File Name"
        .InitialFileName = "File_" & Format(Now(), "mmddyyyy") & ".xlsx"

        If .Show = True Then
            wbOutput.SaveAs FileName:=fd.InitialFileName, FileFormat:=50
            wbOutput.Close
        End If
    End With

End Sub

答案

您的filedialog代码无法正常工作，因此，您无法获得有效的文件名和位置。

如果要返回拾取的文件名，则应使用.SelectedItems(1)，而不是.InitialFileName。 .InitialFileName设置初始值并且不返回完整路径。

    If .Show = True Then
        wbOutput.SaveAs FileName:=.SelectedItems(1), FileFormat:=50
        wbOutput.Close
    End If

如果您使用了有效的错误处理程序，这可能会更容易捕获。使用On Error GoTo 0使用默认错误处理程序。