文件保存问题，100分相赠送～～～

Question

新学习vb，要完成一个.xls文件导入和保存功能。具体就是说：在一个form上两个commandbutton，分别是文件导入和保存按钮。datagrid里显示导入的.xls文件，然后有几个textbox.现在要求在导入文件后，填写几个textbox的内容，然后整个以一个.xls的形式保存出来。请高手帮帮忙，导入文件我已经做好了，就是保存没有完成。请给出详细些的注释。100分相赠送，绝不食言。急啊。

Answer 1

Private Sub Command2_Click()
'首先在"工程"--"引用"中引用Microsoft Excel 11.0 Object Library(这个视你的office版本,有可能是10.0等等)
Dim ColCount As Long, RowCount As Long, i As Long, k As Long, kk As Long
    Dim xlApp As New Excel.Application, xlBook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet, sRange As String
    xlApp.Visible = False    Set xlBook = xlApp.Workbooks.Open(App.Path & "\KK.XLS") 'XLS文件的路径
    Set xlsheet = xlBook.Worksheets(1)
    xlsheet.Name = "导入数据"
    VB.Screen.MousePointer = vbHourglass
        xlsheet.Cells(1, 1) = "ABC" '就在这里填入内容,那两个1就第一行第一列,你可以用循环分别附值给第N列第N行.
    xlsheet.Cells(2, 1) = "ABC"
    
'//关闭操作台
   xlBook.Save
    xlBook.Close False
    xlApp.Quit
    Set xlApp = Nothing
    VB.Screen.MousePointer = vbDefault
     MsgBox "OK"
End Sub

Answer 2

可是我把.xls数据导入到datagrid的时候，发现读取出来的时候只能读取可见的一些数据。我用的语句是：
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
i = DataGrid1.VisibleRows
j = DataGrid1.VisibleColsFor M = 4 To i
For N = 0 To j
DataGrid1.Row = M
DataGrid1.Col = N
xlSheet.Cells(M + 1, N + 1) = DataGrid1.Text
Next N
Next M
如果不用visible的话，那么就不能读取grid的数据了。
请指点

Answer 3

//如果不用visible的话，那么就不能读取grid的数据了。
那是因为你用了
i = DataGrid1.VisibleRows
j = DataGrid1.VisibleCols
来获得datagrid得行数和列数啊！
由于datagrid只能支持绑定模式，因此它得记录行数和列数都是和Recordset得RecordCount相关得！

Answer 4

CommonDialog1.Flags = cdlOFNOverwritePrompt
CommonDialog1.Filter = " EXCEL 电子表格(*.xls)| *.xls"
CommonDialog1.ShowSave
newFilename = CommonDialog1.FileName
Set xlApp = CreateObject("Excel.Application")
'Set xlBook = xlApp.Workbooks.Open("G:\duda\d\d.xls")
Set xlBook = xlApp.Workbooks.Open("D:\机场海关\d\d\d\c.xls")
Set xlSheet = xlBook.Worksheets(1)
For i = 1 To dListView.ListItems.Count
    For j = 1 To 10
    xlSheet.Cells(i + 6, j) = CStr(dListView.ListItems.Item(i).SubItems(j))
    Next j
Next i
    
    
    xlBook.SaveAs newFilename
    xlBook.Close
    xlApp.Quit   '完成时，调用 Quit 方法关闭
    Set xlApp = Nothing   '该应用程序，然后释放该引用。

Answer 5

转
Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
    Dim Rs_Data As New ADODB.Recordset
    Dim Irowcount As Integer
    Dim Icolcount As Integer
    Dim cn As New ADODB.Connection
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = "provider=msdasql;DRIVER=Microsoft Visual FoxPro Driver;UID=;Deleted=yes;Null=no;Collate=Machine;BackgroundFetch=no;Exclusive=No;SourceType=DBF;SourceDB=D:\DBF;"
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .Source = strOpen
        .Open
    End With
    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Function
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count
    End With
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = True
    
    '添加查询语句，导入EXCEL数据
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
    
    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh
    
    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing
    
End Function
-------------------------------------------------------------------------------
'*************************************************************************
'**
'** VB将数据导出到EXCEL,没有安装EXCEL的一样也可以导出.
'**
'** 调用方式: s_Export2Excel(Ado.Recordset) 或 s_Export2Excel(Rds.RecordSet)
'** 支持 Rds 与 Ado 的记录导出
'**
'*************************************************************************'导出ADO记录集到EXCEL
Public Function f_Export2Excel(ByVal sRecordSet As ADODB.Recordset, ByVal sExcelFileName$ _
        , Optional ByVal sTableName$, Optional ByVal sOverExist As Boolean = False) As Boolean
    
    'On Error GoTo lbErr
    
    Dim iConcStr, iSql$, iFdlist$, iDb As ADODB.Connection
    Dim iI&, iFdType$, j, TmpField, FileName
    Dim iRe As Boolean    
    '检查文件名
    If Dir(sExcelFileName) <> "" Then
        If sOverExist Then
            Kill sExcelFileName
        Else
            iRe = False
            GoTo lbExit
        End If
    End If
    
    '生成创建表的SQL语句
    With sRecordSet
        For iI = 0 To .Fields.Count - 1
            iFdType = f_FieldType(.Fields(iI).Type)
            Select Case iFdType
                Case "char", "varchar", "nchar", "nvarchar", "varbinary"
                    If .Fields(iI).DefinedSize > 255 Then
                        iSql = iSql & ",[" & .Fields(iI).Name & "] text"
                    Else
                        iSql = iSql & ",[" & .Fields(iI).Name & "] " & iFdType & _
                            "(" & .Fields(iI).DefinedSize & ")"
                    End If
                Case "image"
                Case Else
                    iSql = iSql & ",[" & .Fields(iI).Name & "] " & iFdType
            End Select
        Next
        
        If sTableName = "" Then sTableName = .Source
        iSql = "create table [" & sTableName & "](" & Mid(iSql, 2) & ")"
    End With
    
    '数据库连接字符串
    iConcStr = "DRIVER={Microsoft Excel Driver (*.xls)};DSN='';FIRSTROWHASNAMES=1;READONLY=FALSE;" & _
            "CREATE_DB=""" & sExcelFileName & """;DBQ=" & sExcelFileName
    
    '创建Excel文件,并创建表
    Set iDb = New ADODB.Connection
    iDb.Open iConcStr
    iDb.Execute iSql
    
    '插入数据
    With sRecordSet
        .MoveFirst
        While .EOF = False
            iSql = ""
            iFdlist = ""
            For iI = 0 To .Fields.Count - 1
                iFdType = f_FieldType(.Fields(iI).Type)
                If iFdType <> "image" And IsNull(.Fields(iI).Value) = False Then
                    iFdlist = iFdlist & ",[" & .Fields(iI).Name & "]"
                    Select Case iFdType
                        Case "char", "varchar", "nchar", "nvarchar", "text"
                            iSql = iSql & ",'" & .Fields(iI).Value & "'"
                        Case "datetime"
                            iSql = iSql & ",#" & .Fields(iI).Value & "#"
                        Case "image"
                        Case Else
                            iSql = iSql & "," & .Fields(iI).Value
                    End Select
                End If
            Next
            iSql = "insert into [" & sTableName & "](" & _
                Mid(iFdlist, 2) & ") values(" & Mid(iSql, 2) & ")"
            iDb.Execute iSql
            .MoveNext
        Wend
    End With    '处理完毕,关闭数据库
    iDb.Close
    Set iDb = Nothing
    
    MsgBox "已经将数据保存到 [ " & sExcelFileName & " ]", 64
    iRe = True
    GoTo lbExitlbErr:
    MsgBox "发生错误:" & Err.Description & vbCrLf & _
        "错误代码:" & Err.Number, 64, "错误"
lbExit:
    f_Export2Excel = iRe
End Function'得到所有数据类型,有些数据类型EXCEL不支持,已经替换掉
Public Function f_FieldType$(ByVal sType&)
    Dim iRe$
    Select Case sType
        Case 2, 3, 20
            iRe = "int"
        Case 5
            iRe = "float"
        Case 6
            iRe = "money"
        Case 131
            iRe = "numeric"
        Case 4
            iRe = "real"
        Case 128
            iRe = "binary"
        Case 204
           iRe = "varbinary"
        Case 11
            iRe = "bit"
        Case 129, 130
            iRe = "char"
        Case 17, 72, 131, 200, 202, 204
            iRe = "varchar"
        Case 201, 203
            iRe = "text"
        Case 7, 135
            iRe = "datetime"
        Case 205
            iRe = "image"
        Case 128
            iRe = "timestamp"
    End Select
    f_FieldType = iRe
End Function
'调用测试
Sub test()
    Dim iRe As ADODB.Recordset
    Dim iConc As String
    
    iConc = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False" & _
        ";Data Source=F:\My Documents\客户资料.mdb"
        
    Set iRe = New ADODB.Recordset
    iRe.Open "维护员", iConc, adOpenKeyset, adLockOptimistic
    f_Export2Excel iRe, "c:\b.xls", , True
    iRe.Close
End Sub