hhjjhjhj(大头)及其他高手救命,仍是上次VB访问ACCESS数据库,然后结果转存EXCEL问题.

程序添加了hhjjhjhj(大头)朋友的意见,同时添加了一个 common dialog控件，以选择存放文件的路径及文件名。有两种情况下,会出错(程序在下面).
    其一:点击VB窗体的“另存为”按钮，会首先出现common dialog控件的“保存文件对话框”，选择一个已有的文件名，点击“保存”命令键，首先common dialog控件会给一个提示：***.xls已存在，要替换它吗？
    选择是，会继续出现excel提示：在当前位置发现已经存在名为“***.xls”的文件。是否替换现有的“***.xls”?
    有：“是”“否”，“取消”三个选项，选择是，程序正常，退出到VB界面,选择否和取消，都会提示：
    实时错误'1004'
    对象 'save'的方法 '_worksheet'失败（语句xlbook.save出现错误）    其二:点击VB窗体的“另存为”按钮，出现common dialog控件的“保存文件对话框”，点击取消.回到VB界面.
    上述过程执行N次,在WIN2000关机时候,就会提示N次:book1,book2....book文件已经更改,是否保存其修改?
-----------------------------------------------------
Private Sub cmdSaveAs_Click()    Dim i As Integer
    Dim j As Integer
    Dim rCount As Long
        
    Dim cn As New ADODB.Connection
    Dim Cmd As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim strConnect As String
    Dim StrSql As String
    StrSql = "select * from parameter_add_material where time_charging between # " & Format(time_begin, "yyyy-mm-dd") & " #  and # " & Format(time_end, "yyyy-mm-dd") & " # "    Set cn = New ADODB.Connection
                
    strConnect = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=d:\db\shaft_furnace.mdb"  '指定连接字符串
    cn.ConnectionString = strConnect
    cn.Open
    With Cmd
        .ActiveConnection = cn
        .CommandType = adCmdText
        .CommandText = StrSql
        .Parameters.Refresh
    End With    With rs
        .CursorLocation = adOpenStatic
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Open Cmd
    End With
    
    '---------------------------------------
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    
    If rs.RecordCount > 0 Then
        
        For i = 0 To rs.Fields.Count - 1
            xlSheet.Cells(1, i + 1).Value = rs(i).Name
        Next
        rs.MoveLast
        rs.MoveFirst
        rCount = rs.RecordCount
        i = 0
        
        Do While Not rs.EOF
            For j = 0 To rs.Fields.Count - 1
                xlSheet.Cells(i + 2, j + 1).Value = rs(j)
            Next
            rs.MoveNext
            i = i + 1
        Loop
        
        Dim shaftSave As String
        shaftSave = ""
        CommonDialog1.DialogTitle = "保存文件"
        CommonDialog1.Filter = "xls文件|*.xls"
        CommonDialog1.FilterIndex = 1
        CommonDialog1.InitDir = "d:\db"
        CommonDialog1.Flags = 6
        CommonDialog1.Action = 2
        shaftSave = CommonDialog1.FileName
        If shaftSave <> "" Then
            xlSheet.SaveAs shaftSave
            On Error Resume Next   
            xlBook.Save
            'xlSheet.SaveWorkspace   '这一句有语法错误
            xlSheet.Application.Quit
        End If
        shaftSave = ""   End If
    '---------------------------------------
    Set xlApp = Nothing  
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set rs = Nothing
    cn.Close
    '------------------------------------------
End Sub

解决方案 »

  1.   

    点击保存之前，把CommonDialog1.filename="" 则不会出现上次的文件名了
      

  2.   

    参考
    http://www.csdn.net/develop/read_article.asp?id=14952
      

  3.   

    点击保存之前，把CommonDialog1.filename="" 则不会出现上次的文件名了
    -------------
    不是,我是查找错误,故意找一个已有xls文件覆盖,会出现上述错误.
      

  4.   

    .................
            Loop
            
            Dim shaftSave 
            shaftSave = xlApp.GetSaveAsFilename(, "Excel Files (*.xls), *.xls")
            If shaftSave <> false Then
                On Error Resume Next  
                xlBook.SaveAs shaftSave 
            End If
            shaftSave = ""
            xlApp.Quit
      

  5.   

    再次感谢hhjjhjhj(大头)朋友,现在OK了.