注意：不使用docmd outputto acoutputtable(可自动输出字段名字)是因为access的日期字段导入到excel会显示英文月份。因此采用事先建立模版，利用此模版另存为的方式保存到Excel中。

Private Sub Command16_Click()

'导出到excel

Dim str As String

If mykey = 1 Then

    str = Me.txtm.Value & "月生日人员名单.xls"

ElseIf mykey = 2 Then

    str = Me.txty.Value & "年" & Me.txtmon.Value & "月合同到期人员名单.xls"

ElseIf mykey = 4 And Me.frax.Value = 1 Then

    str = Me.txtaxym & " 新入职" & Me.txtaxm & "个月员工 爱心名单.xls"

ElseIf mykey = 4 And Me.frax.Value = 2 Then

    str = Me.txtaxym & " 所有在职" & Me.txtaxm & "个月员工 爱心名单.xls"

Else

End If

 

Dim strpath As String

Dim strpathm As String

 

'strpath = CurrentProject.Path & "\" & Me.txtm.Value & "月生日人员名单.xls"

strpath = CurrentProject.Path & "\" & str

strpathm = CurrentProject.Path & "\" & "m1.xlt"

 

With FileDialog(2)  '1-打开 文件对话框  2-保存 文件对话框

    .InitialFileName = strpath

    If .Show Then

        strpath = .SelectedItems(1) '文件对话框的保存目录

        

        DoCmd.Hourglass True

        

        'docmd outputto...为Access中的导出功能

        'DoCmd.OutputTo acOutputForm, "Child4", acFormatXLS, strpath, False

        'DoCmd.OutputTo acOutputTable, "ttblhr", acFormatXLS, strpath, True

        

        'Dim objapp As Object   '也可直接声明成excel.application

        Dim objapp As Excel.Application

        Dim objbook As Excel.Workbook

        Dim objsheet As Excel.Worksheet

        Dim rst As Recordset

        Dim r As Integer

        Dim c As Integer

        'Dim a As Excel.Application

        'Dim b As Excel.Workbooks

        Set objapp = CreateObject("excel.application")

        'Debug.Print objapp.Version

        Set objbook = objapp.Workbooks.Open(strpathm)

        objbook.sheets("m1").select

        'Set objsheet = objbook.Worksheets("表名")

        Set rst = Me.Child4.Form.Recordset

        

        '注意CopyFromRecordset可以实现，但excel格式问题不好控制，如日期、×××等

        'objbook.application.Range("A2").CopyFromRecordset rst

        

        rst.MoveFirst

        r = 2

        While Not rst.EOF

            For c = 1 To 7

                objbook.Application.Cells(r, c).Value = rst.Fields(c - 1)

            Next c

            rst.MoveNext

            r = r + 1

        Wend

        

        objbook.SaveAs strpath

        objapp.Quit '必须退出，否则打开导出的excel会有错误

        

        objapp.Visible = ture

        'objbook.Saved = True

        Set objapp = Nothing

        Set objbook = Nothing

        

        DoCmd.Hourglass False

        MsgBox "【OK】已成功到处Excel表格", vbOKOnly + 64, "提示"

        

    End If

 

End With

 

End Sub