Access交流中心

北京 | 上海 | 天津 | 重庆 | 广州 | 深圳 | 珠海 | 汕头 | 佛山 | 中山 | 东莞 | 南京 | 苏州 | 无锡 | 常州 | 南通 | 扬州 | 徐州 | 杭州 | 温州 | 宁波 | 台州 | 福州 | 厦门 | 泉州 | 龙岩 | 合肥 | 芜湖 | 成都 | 遂宁 | 长沙 | 株洲 | 湘潭 | 武汉 | 南昌 | 济南 | 青岛 | 烟台 | 潍坊 | 淄博 | 济宁 | 太原 | 郑州 | 石家庄 | 保定 | 唐山 | 西安 | 大连 | 沈阳 | 长春 | 昆明 | 兰州 | 哈尔滨 | 佳木斯 | 南宁 | 桂林 | 海口 | 贵阳 | 西宁 | 乌鲁木齐 | 包头 |

能否类似下列代码一样另存和打开Word文档

hj  发表于:2011-02-05 12:31:23  
复制

Private Sub cmdExportToExcel_Click()
    On Error GoTo Err_cmdExportToExcel_Click
    Dim strTemplate As String           '模板文件路径名
    Dim strPathName As String           '输出文件路径名
    Dim objApp As Object                'Excel程序
    Dim objBook As Object               'Excel工作簿
    Dim rst As Object                   '子窗体记录集
        
    
    '当前是新记录则提示并退出
    If Me.NewRecord Then
        MsgBox "当前没有可导出!", vbExclamation, "提示"
        Exit Sub
    End If

    '模板文件路径
    strTemplate = CurrentProject.Path & "\订单模板.xlt"

    '通过文件对话框取得另存为文件名
    With FileDialog(2)    'msoFileDialogSaveAs
        .InitialFileName = CurrentProject.Path & "\订单 " & _
                           Me.客户ID.Column(1) & " " & Me.订单ID & ".xls"
        If .Show Then strPathName = .SelectedItems(1)
    End With
    '对话框被取消则退出过程
    If strPathName = "" Then Exit Sub
    '如果文件名后没有.xls扩展名则加上
'    If Not strPathName Like "*.xls" Then strPathName = strPathName & ".xls"
    '忽略错误
    On Error Resume Next
    '删除已有文件
    Kill strPathName
    '恢复错误处理
    On Error GoTo Err_cmdExportToExcel_Click

    '设置鼠标指针为沙漏形状
    DoCmd.Hourglass True
    '创建Excel对象
    Set objApp = CreateObject("Excel.Application")
    '打开模板文件
    Set objBook = objApp.Workbooks.Open(strTemplate)
    objBook.Sheets("销售订单").Select
      

 

 '保存Excel文件,因为模板是不能修改的,所以是另存为
    objBook.SaveAs strPathName
    objBook.Saved = True
    objBook.Close False
    objApp.Quit

       If MsgBox("导出已完成,是否打开导出的Excel文件?", vbQuestion + vbYesNo, "导出完成") = vbYes Then
        Shell "EXCEL """ & strPathName & """", vbNormalFocus
       End If

Exit_cmdExportToExcel_Click:
    '恢复鼠标指针
    DoCmd.Hourglass False
    '释放对象变量内存
    Set objApp = Nothing
    Set objBook = Nothing
    Set rst = Nothing
    Exit Sub

Err_cmdExportToExcel_Click:        '错误处理程序
    If Err = 70 Then
        MsgBox "不能替换文件,因为无法删除已有文件,可能的原因有:" & vbCrLf & vbCrLf & _
               "1.该文件处于打开状态。" & vbCrLf & _
               "2.没有对此目录的写入权限。", vbCritical
    Else
        MsgBox Err & vbCrLf & Err.Description, vbCritical, "出错"
    End If
    Resume Exit_cmdExportToExcel_Click

 

Top
煮江品茶 发表于:2011-02-06 18:54:33
请参见《齐人之福》一文。

hj 发表于:2011-02-11 22:55:49

已搞定。谢谢!!



总记录:2篇  页次:1/1 9 1 :