Vb6导出数据到Excel或word文件中

VB6.0报表导出的实现一例，将内容导出到Excel中，或者导出到Word文件中，在平时挺实用，不过代码只测试了下，可以用，核心代码如下:

VERSION 5.00
Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDATGRD.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
Caption = "报表导出"
ClientHeight = 5910
ClientLeft = 60
ClientTop = 345
ClientWidth = 7410
LinkTopic = "Form1"
ScaleHeight = 5910
ScaleWidth = 7410
StartUpPosition = 3 '窗口缺省
Begin MSAdodcLib.Adodc Adodc1
Height = 570
Left = 825
Top = 6075
Width = 2025
_ExtentX = 3572
_ExtentY = 1005
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 8
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 1
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = ""
OLEDBString = ""
OLEDBFile = ""
DataSourceName = ""
OtherAttributes = ""
UserName = ""
Password = ""
RecordSource = ""
Caption = "Adodc1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
Begin VB.Frame Frame1
Appearance = 0 'Flat
BackColor = &H80000000&
ForeColor = &H80000008&
Height = 1095
Left = 15
TabIndex = 1
Top = 825
Width = 7335
Begin VB.ComboBox cboFields
BackColor = &H00FFFFC0&
Height = 300
Left = 975
Style = 2 'Dropdown List
TabIndex = 4
Top = 240
Width = 3555
End
Begin VB.TextBox txtdata
BackColor = &H00FFFFC0&
Height = 300
Left = 945
TabIndex = 3
Top = 690
Width = 6165
End
Begin VB.ComboBox cboOperator
BackColor = &H00FFFFC0&
Height = 300
Left = 5325
Style = 2 'Dropdown List
TabIndex = 2
Top = 255
Width = 1725
End
Begin VB.Label Label3
Caption = "关键字"
ForeColor = &H00FF0000&
Height = 255
Left = 4650
TabIndex = 7
Top = 285
Width = 570
End
Begin VB.Label Label1
Caption = "字段名称"
ForeColor = &H00FF0000&
Height = 285
Left = 150
TabIndex = 6
Top = 315
Width = 915
End
Begin VB.Label Label2
Caption = "关 键 字"
ForeColor = &H00FF0000&
Height = 255
Left = 135
TabIndex = 5
Top = 750
Width = 1155
End
End
Begin MSComctlLib.Toolbar Toolbar1
Align = 1 'Align Top
Height = 855
Left = 0
TabIndex = 0
Top = 0
Width = 7410
_ExtentX = 13070
_ExtentY = 1508
ButtonWidth = 1931
ButtonHeight = 1349
Appearance = 1
ImageList = "ImageList1"
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 6
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "查询"
ImageIndex = 1
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "导出到Word"
ImageIndex = 2
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "导出到Excel"
ImageIndex = 3
EndProperty
BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "导出到HTML"
ImageIndex = 4
EndProperty
BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "打印"
ImageIndex = 5
EndProperty
BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "退出"
ImageIndex = 6
EndProperty
EndProperty
Begin MSComctlLib.ImageList ImageList1
Left = 6810
Top = 150
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 32
ImageHeight = 32
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 6
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":0000
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":0CDA
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":19B4
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":268E
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":3368
Key = ""
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Form1.frx":4042
Key = ""
EndProperty
EndProperty
End
End
Begin MSDataGridLib.DataGrid DataGrid1
Bindings = "Form1.frx":4D1C
Height = 3885
Left = 15
TabIndex = 8
Top = 1995
Width = 7365
_ExtentX = 12991
_ExtentY = 6853
_Version = 393216
AllowUpdate = 0 'False
HeadLines = 1
RowHeight = 15
FormatLocked = -1 'True
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ColumnCount = 12
BeginProperty Column00
DataField = "商品编号"
Caption = "商品编号"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column01
DataField = "商品名称"
Caption = "商品名称"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column02
DataField = "拼音码"
Caption = "拼音码"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column03
DataField = "批号"
Caption = "批号"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column04
DataField = "产地"
Caption = "产地"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column05
DataField = "规格"
Caption = "规格"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column06
DataField = "包装"
Caption = "包装"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column07
DataField = "单位"
Caption = "单位"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column08
DataField = "进价"
Caption = "进价"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column09
DataField = "库存"
Caption = "库存"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column10
DataField = "盘点数量"
Caption = "盘点数量"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column11
DataField = "盘点盈亏数量"
Caption = "盘点盈亏数量"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
SplitCount = 1
BeginProperty Split0
MarqueeStyle = 4
SizeMode = 1
BeginProperty Column00
ColumnWidth = 750.047
EndProperty
BeginProperty Column01
ColumnWidth = 1500.095
EndProperty
BeginProperty Column02
ColumnWidth = 659.906
EndProperty
BeginProperty Column03
ColumnWidth = 599.811
EndProperty
BeginProperty Column04
ColumnWidth = 599.811
EndProperty
BeginProperty Column05
ColumnWidth = 659.906
EndProperty
BeginProperty Column06
ColumnWidth = 494.929
EndProperty
BeginProperty Column07
ColumnWidth = 480.189
EndProperty
BeginProperty Column08
ColumnWidth = 585.071
EndProperty
BeginProperty Column09
ColumnWidth = 569.764
EndProperty
BeginProperty Column10
ColumnWidth = 884.976
EndProperty
BeginProperty Column11
ColumnWidth = 1154.835
EndProperty
EndProperty
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
' http://www.codesc.net
Attribute VB_Exposed = False
Option Explicit
Public tb As String, sql As String
Private Sub Form_Load()
Dim fld
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\db_medicine.mdb;Persist Security Info=False"
Adodc1.RecordSource = "select * from tb_kc"
Adodc1.Refresh
sql = "tb_kc"
Set fld = Adodc1.Recordset.Fields
For Each fld In Adodc1.Recordset.Fields
'向combo控件中添加字段
cboFields.AddItem fld.Name
Next
cboFields.ListIndex = 0
'向cboOperator中添加查询条件
cboOperator.AddItem ("like")
cboOperator.AddItem (">")
cboOperator.AddItem ("=")
cboOperator.AddItem (">=")
cboOperator.AddItem ("<")
cboOperator.AddItem ("<=")
cboOperator.AddItem ("<>")
cboOperator.ListIndex = 0
'Download by <a href="http://www.srcfans.comEnd">http://www.srcfans.com End</a> Sub
Private Sub ExptoExcel()
Dim i As Integer, r As Integer, c As Integer
Dim newxls As New Excel.Application
Dim newbook As New Excel.Workbook
Dim newsheet As New Excel.Worksheet
Set newbook = newxls.Workbooks.Add '创建工作簿
Set newsheet = newbook.Worksheets(1) '创建工作表
If sql <> "" Then
Adodc1.RecordSource = sql
Adodc1.Refresh
End If
If Adodc1.Recordset.RecordCount > 0 Then
For i = 0 To DataGrid1.Columns.Count - 1
newsheet.Cells(1, i + 1) = DataGrid1.Columns(i).Caption
Next i
'指定表格内容
Adodc1.Recordset.MoveFirst
Do Until Adodc1.Recordset.EOF
r = Adodc1.Recordset.AbsolutePosition
For c = 0 To DataGrid1.Columns.Count - 1
DataGrid1.Col = c
newsheet.Cells(r + 1, c + 1) = DataGrid1.Columns(c)
Next c
Adodc1.Recordset.MoveNext
Loop
Dim myval As Long
Dim mystr As String
myval = MsgBox("是否保存该Excel表?", vbYesNo, "提示窗口")
If myval = vbYes Then
mystr = InputBox("请输入文件名称", "输入窗口")
If Len(mystr) = 0 Then
MsgBox "系统不允许文件名称为空！", , "提示窗口"
Exit Sub
End If
On Error GoTo ErrSave
newsheet.SaveAs App.Path & "\Excel文件\" & mystr & ".xls"
MsgBox "Excel文件保存成功，位置：" & App.Path & "\Excel文件\" & mystr & ".xls", , "提示窗口"
newxls.Quit
ErrSave:
Exit Sub
MsgBox Err.Description, , "提示窗口"
End If
End If
End Sub
Private Sub ExptoWord()
Dim i As Integer, j As Integer
Dim ifieldcount As Integer, irecordcount As Integer
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim atable As Word.Table
' cmdFind_Click
If Adodc1.Recordset.RecordCount > 0 Then
irecordcount = Adodc1.Recordset.RecordCount
'创建word应用程序，这一句话打开word2000
Set wdapp = CreateObject("Word.Application")
'在word中添加一个新文档
Set wddoc = wdapp.Documents.Add
With wdapp
.Visible = True
.Activate
'在word中增加一个表格
.Caption = "商品信息表"
Set atable = .ActiveDocument.Tables.Add(.Selection.Range, irecordcount + 1, 12)
atable.Cell(1, 1).Range.InsertAfter "商品编号"
atable.Cell(1, 2).Range.InsertAfter "商品名称"
atable.Cell(1, 3).Range.InsertAfter "拼音码"
atable.Cell(1, 4).Range.InsertAfter "批号"
atable.Cell(1, 5).Range.InsertAfter "产地"
atable.Cell(1, 6).Range.InsertAfter "规格"
atable.Cell(1, 7).Range.InsertAfter "包装"
atable.Cell(1, 8).Range.InsertAfter "单位"
atable.Cell(1, 9).Range.InsertAfter "进价"
atable.Cell(1, 10).Range.InsertAfter "库存"
atable.Cell(1, 11).Range.InsertAfter "盘点数量"
atable.Cell(1, 12).Range.InsertAfter "盘点盈亏数量"
'指定表格内容
Adodc1.Recordset.MoveFirst
Do Until Adodc1.Recordset.EOF
atable.Cell(DataGrid1.Bookmark + 1, 1).Range.InsertAfter Adodc1.Recordset.Fields("商品编号")
atable.Cell(DataGrid1.Bookmark + 1, 2).Range.InsertAfter Adodc1.Recordset.Fields("商品名称")
atable.Cell(DataGrid1.Bookmark + 1, 3).Range.InsertAfter Adodc1.Recordset.Fields("拼音码")
If Adodc1.Recordset.Fields("批号") <> "" Then atable.Cell(DataGrid1.Bookmark + 1, 4).Range.InsertAfter Adodc1.Recordset.Fields("批号")
If Adodc1.Recordset.Fields("产地") <> "" Then atable.Cell(DataGrid1.Bookmark + 1, 5).Range.InsertAfter Adodc1.Recordset.Fields("产地")
If Adodc1.Recordset.Fields("规格") <> "" Then atable.Cell(DataGrid1.Bookmark + 1, 6).Range.InsertAfter Adodc1.Recordset.Fields("规格")
If Adodc1.Recordset.Fields("包装") <> "" Then atable.Cell(DataGrid1.Bookmark + 1, 7).Range.InsertAfter Adodc1.Recordset.Fields("包装")
If Adodc1.Recordset.Fields("单位") <> "" Then atable.Cell(DataGrid1.Bookmark + 1, 8).Range.InsertAfter Adodc1.Recordset.Fields("单位")
If Adodc1.Recordset.Fields("进价") <> "" Then atable.Cell(DataGrid1.Bookmark + 1, 9).Range.InsertAfter Adodc1.Recordset.Fields("进价")
If Adodc1.Recordset.Fields("库存") <> "" Then atable.Cell(DataGrid1.Bookmark + 1, 10).Range.InsertAfter Adodc1.Recordset.Fields("库存")
If Adodc1.Recordset.Fields("盘点数量") <> "" Then atable.Cell(DataGrid1.Bookmark + 1, 11).Range.InsertAfter Adodc1.Recordset.Fields("盘点数量")
If Adodc1.Recordset.Fields("盘点盈亏数量") <> "" Then atable.Cell(DataGrid1.Bookmark + 1, 12).Range.InsertAfter Adodc1.Recordset.Fields("盘点盈亏数量")
Adodc1.Recordset.MoveNext
Loop
End With
'清除word对象
Set wdapp = Nothing
Set wddoc = Nothing
Else
MsgBox "没有商品！", , "提示窗口"
End If
End Sub
Private Sub cFind() '查询
tb = "tb_kc"
Select Case Adodc1.Recordset.Fields(cboFields.ListIndex).Type
Case 202 '字符数据
If cboOperator.Text = "like" Then
sql = tb & " where " & tb & "." & cboFields & " like+ '" + txtdata + "'+'%'"
Else
sql = tb & " where " & tb & "." & cboFields & cboOperator & "'" + txtdata + "'"
End If
Case 5 '货币数据
If IsNumeric(txtdata) = False Then
MsgBox "请输入正确的数据！", , "提示窗口"
Exit Sub
End If
If cboOperator.Text = "like" Then
MsgBox "货币数据不能选用“Like”作为运算符！", , "提示窗口"
cboOperator.ListIndex = 1
End If
sql = tb & " where " & tb & "." & cboFields & cboOperator & txtdata
Case 3 '数字数据
If IsNumeric(txtdata) = False Then
MsgBox "请输入正确的数据！", , "提示窗口"
Exit Sub
End If
If cboOperator.Text = "like" Then
MsgBox "数字数据不能选用“Like”作为运算符！", , "提示窗口"
cboOperator.ListIndex = 1
End If
sql = tb & " where " & tb & "." & cboFields & cboOperator & txtdata
End Select
If sql <> "" Then
Adodc1.RecordSource = sql
Adodc1.Refresh
End If
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Caption
Case "查询"
cFind
Case "导出到Word"
ExptoWord
Case "导出到Excel"
ExptoExcel
Case "导出到HTML"
If DataEnvironment1.Connection1.State = adStateOpen Then
DataEnvironment1.Connection1.Close
End If
DataEnvironment1.Connection1.Open
DataEnvironment1.Commands(1).ActiveConnection = DataEnvironment1.Connection1
DataEnvironment1.Commands(1).CommandText = sql
DataReport1.Refresh
DataReport1.ExportReport rptKeyHTML, "" & App.Path & "\Myfile.htm ", True, , rptRangeAllPages
MsgBox "文件已导出到工程目录下！", vbInformation, "信息提示"
Case "打印"
If DataEnvironment1.Connection1.State = adStateOpen Then
DataEnvironment1.Connection1.Close
End If
DataEnvironment1.Connection1.Open
DataEnvironment1.Commands(1).ActiveConnection = DataEnvironment1.Connection1
DataEnvironment1.Commands(1).CommandText = sql
DataReport1.Show
DataReport1.Refresh
DataReport1.Show
Case "退出"
End
End Select
End Sub

这里可以代码高亮，看的更清：Vb导出数据到Excel或word文件中