VB6中如何导出EXCEL、FOXPRO格式的表

'注释：请先引用ADODB类库。
Dim Export_Str, mdbTable As String
Dim rsExport As New ADODB.Recordset
Dim conn As New ADODB.Connection
Private Sub Close_cmd_Click()
Unload Me
End Sub

Private Sub EXport_cmd_Click()
Dim myPath, myStr As String, myPos As Integer

注释：*****************处理选择的各种表的导出
With Dialog1
If myOption(2).Value Then
.FilterIndex = 1
.ShowSave
myStr = StrReverse(.FileName) 注释：串取反
myPos = InStr(myStr, “”) 注释：在反字符串中，找从左开始第一个\的位置
On Error GoTo myError 注释：防FILENAME为空，MID出错
myPath = StrReverse(Mid(myStr, myPos)) 注释：取目录部分，并还原.
myStr = StrReverse(Left(myStr, myPos - 1)) 注释：取文件名
Export_Str = “select * into [dBase III;database=” & myPath & “].” & myStr & " from Customers"
.DefaultExt = ".DBF"

ElseIf myOption(3).Value Then
mdbTable = InputBox(“请给导出到MDB文件的表确定表名”)
.FilterIndex = 2
.ShowSave
Export_Str = “select * into [;database=” & .FileName & “].” & mdbTable & " from Customers"
.DefaultExt = “*.MDB”

ElseIf myOption(4).Value Then
.FilterIndex = 3
.ShowSave
Export_Str = “select * into [Excel 8.0;database=” & .FileName & “].Customers from Customers”
.DefaultExt = “*.XLS”

ElseIf myOption(5).Value Then
.FilterIndex = 4
.ShowSave
myStr = StrReverse(.FileName) 注释：串取反
myPos = InStr(myStr, “”) 注释：在反字符串中，找从左开始第一个\的位置
On Error GoTo myError 注释：防FILENAME为空，MID出错
myPath = StrReverse(Mid(myStr, myPos)) 注释：取目录部分，并还原.
myStr = StrReverse(Left(myStr, myPos - 1)) 注释：取文件名
Export_Str = “select * into [Paradox 4.X;database=” & myPath & “].” & myStr & " from Customers"
.DefaultExt = “*.DB”
End If
End With

注释：*****生成文件
Debug.Print Export_Str
If rsExport.State = 1 Then
rsExport.Close
End If

If Dir(Dialog1.FileName) <> “” Then
On Error GoTo myError 注释：防用户没选文件
If Dialog1.FilterIndex <> 2 Then
Kill (Dialog1.FileName)
End If
rsExport.Open Export_Str, conn, adOpenStatic, adLockOptimistic
Else
rsExport.Open Export_Str, conn, adOpenStatic, adLockOptimistic
End If
myError:
Exit Sub
End Sub

Private Sub Form_Load()
注释：联接数据库并打开记录集
conn.CursorLocation = adUseServer
conn.Open “PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=” + App.Path + “\NWind.mdb;”
rsExport.Open “select *from Customers”, conn, adOpenStatic, adLockOptimistic
Set Grid1.DataSource = rsExport

注释：初始化对话筐
With Dialog1
.Filter = “FoxBase/FoxPro (.DBF)|.DBF|Access 8.0(.MDB)|.MDB|Excel 8.0(.XLS)|.XLS|Paradox 4.x(.DB)|.DB”
.DialogTitle = “导出文件为”
.CancelError = False
End With
End Sub`

---

'第二种方法导出excel表格
在工程中引用Microsoft Excel类型库

因为office 版本的不同，在代码写完之后，去掉引用 Microsoft Excel 9.0 Object Library（EXCEL2000

调用 excel 对象之前先创建

比如：

Dim xlApp As Object
Set xlApp = CreateObject(“Excel.Application”)

这样就可以避免因为版本的不同，出现问题了

---

------数据库导出EXCEL-------------

On Error GoTo handles

  conn.ConnectionString = sqlconn '使用连接
   conn.CursorLocation = adUseClient
   conn.Open
   Set rst = conn.Execute(sqlstr)

’ Dim xlApp As Excel.Application
’
’ Dim xlbook As Excel.Workbook
’
’ Dim xlsheet As Excel.Worksheet
Dim xlApp As Object
Dim xlbook As Object
Dim xlsheet As Object

Set xlApp = CreateObject("Excel.Application")
Set xlbook = xlApp.Workbooks.Add 'Excel文件路径及文件名
Set xlsheet = xlbook.Worksheets(1)

  If rst.RecordCount > 1 Then
   
    '获取字段名
    For i = 1 To rs.Fields.Count
   
      xlsheet.Cells(1, i) = rst.Fields(i - 1).Name
   
    Next i
   
    rst.MoveFirst '指针移动到第一条记录
    xlsheet.Range("A2").CopyFromRecordset rst '复制全部数据
   
    '释放结果集，命令对象 和连接对象
    Set rst = Nothing
    Set comm = Nothing
    Set conn = Nothing
   
   xlApp.DisplayAlerts = False
   xlApp.Save
   xlApp.Quit   '关闭Excel
   MsgBox "数据导出完毕！", vbInformation, "金蝶提示"
 
  End If

Exit Sub

handles:

 If Err.Number = 1004 Then
     xlApp.Quit   '关闭Excel
    Exit Sub
Else
   If Err.Number <> 32577 Then
           MsgBox "ErrCode:" & Err & " ErrDescription:" & Err.Description
   End If
   Exit Sub

End If

---

‘’’ Excel表格导出功能
Private Sub Command2_Click()

On Error GoTo handles

Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Set exlBook = xlApp.Workbooks.Add 'Excel文件路径及文件名

    Dim i As Integer
    Dim j As Integer
    Dim k As Integer

    With VSFlexGrid1

        For i = 0 To .Rows - 1  '共有多少行
          j = 0
           For j = 0 To .Cols - 1 '共有多少列

                  xlApp.Sheets(1).Cells(i + 1, j + 1) = .TextMatrix(i, j)
            
          Next j
        Next i

    End With
 
xlApp.DisplayAlerts = False
'exlBook.Close True  '先保存修改再关闭工作簿
xlApp.Save
exlBook.Close True
xlApp.Quit   '关闭Excel
Exit Sub 

handles:

 If Err.Number = 1004 Then
     xlApp.Quit   '关闭Excel
    Exit Sub
Else
   If Err.Number <> 32577 Then
           MsgBox "ErrCode:" & Err & " ErrDescription:" & Err.Description
   End If
   Exit Sub
  
End If

End Sub

‘’'EXCEL表格 导入功能

Private Sub Command3_Click()
'On Error Resume Next
Dim fileadd As String

CommonDialog1.Filter = “xls文件(.xls)|.xls” '选择你要的文件
CommonDialog1.ShowOpen
fileadd = CommonDialog1.FileName

If fileadd <> “” Then '判断是否选择文件
Dim xlApp1 As Object
Dim xlSheet1 As Object

Set xlApp1 = CreateObject("Excel.Application") '创建excel程序
Set xlBook1 = xlApp1.Workbooks.Open(fileadd) '打开存在的Excel表格
Set xlSheet1 = xlBook1.Worksheets(1) '设置活动工作表

Dim lastCol As Integer
Dim lastRow As Integer

lastCol = xlSheet1.UsedRange.Columns.Count 'excel 表格列数
lastRow = xlSheet1.UsedRange.Rows.Count 'Excel 表格行数

'根据 EXCEL 表格中的行列数 确定 vsflexgrid 表的行列数
VSFlexGrid1.Cols = lastCol + 1
VSFlexGrid1.Rows = lastRow + 1
For i = 0 To lastRow - 1
    For j = 1 To lastCol
         VSFlexGrid1.Cell(flexcpText, i, j) = xlSheet1.Cells(i + 1, j).Value
    Next j
Next i
VSFlexGrid1.Refresh
MsgBox "数据导入完毕", vbInformation, "提示"   

Else
MsgBox “请选择文件”, vbExclamation, “提示”
End If
VSFlexGrid1.Redraw = False '关闭表格重画，加快运行速度
End Sub