'新建一个ActiveX DLL工程工程名为DbToExcel 
'工程-->引用,引用Microsoft ActiveX Data Objects 2.6 Library 
'Microsoft Excel 9.0 Objects Library 

Option Explicit 

Private Mcnnquery As ADODB.Connection '定义ADO连接对象 
Private Mrsquery As ADODB.Recordset '定义ADO记录对象 
Dim ObjExcel As Excel.Application '定义Excel对象 
Dim ObjWorkBook As Excel.Workbook '定义工作薄 
Dim ObjSheet As Excel.Worksheet '定义工作表 
Dim ObjRange As Excel.Range '定义用户使用工作表的范围 

Private Property Set Connquery(ByVal Conn As ADODB.Connection) 
Set Mcnnquery = Conn 
End Property 

Private Property Get Connquery() As ADODB.Connection 
Set Connquery = Mcnnquery 
End Property 

Private Property Set Rsquery(ByVal Rs As ADODB.Recordset) 
Set Mrsquery = Rs 
End Property 

Private Property Get Rsquery() As ADODB.Recordset 
Set Rsquery = Mrsquery 
End Property 

'属性方法共有三个参数 
'strcnn 连接对象 
'strrs 数据集对象 
'strpath EXCEL文件 
Public Sub DbtoExcel(Strcnn As ADODB.Connection, Strrs As ADODB.Recordset, Strpath As String) 
Dim i As Integer, j As Integer 
On Error GoTo Err 
Set Connquery = Strcnn '设置cnnquery属性 
Set Rsquery = Strrs '设置rsquery属性 
Set ObjExcel = New Excel.Application 
Set ObjWorkBook = ObjExcel.Workbooks.Open(Strpath) '打开EXCEL文件 
Set ObjSheet = ObjWorkBook.ActiveSheet 
Set ObjRange = ObjSheet.UsedRange '用户使用过的工作表范围 
For i = 1 To Rsquery.Fields.Count 
ObjRange.Cells(1, i) = Rsquery.Fields(i - 1).Name 
Next i 
For j = 1 To Rsquery.RecordCount 
For i = 0 To Rsquery.Fields.Count - 1 
ObjRange.Cells(j + 1, i + 1) = Rsquery.Fields(i).Value 
Next i 
Rsquery.MoveNext 
Next j 
ObjExcel.Quit 
Set ObjWorkBook = Nothing 
Set ObjRange = Nothing 
Set ObjSheet = Nothing 
Set ObjExcel = Nothing 
Err: 
MsgBox Err.Number & " " & Err.Description 
Set ObjWorkBook = Nothing 
Set ObjRange = Nothing 
Set ObjSheet = Nothing 
Set ObjExcel = Nothing 
End Sub 


'文件-->生成DbToExcel.dll 
'新建一个标准EXE工程 
'工程-->引用Microsoft ActiveX Data Objects 2.6 Library 
浏览，加载刚才生成的DLL文件 

Option Explicit 

Dim Conn As ADODB.Connection 
Dim Rs As ADODB.Recordset 

Dim DE As New DbtoExcel.Class1 '定义一个类，DbToExcel.DLL内Class1类的一个实例 

Private Sub Command1_Click() 
DE.DbtoExcel Conn, Rs, "c1.xls" 
End Sub 

Private Sub Form_Load() 
Set Conn = New ADODB.Connection 
Set Rs = New ADODB.Recordset 
Conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:db.mdb;Persist Security Info=False" 
Conn.Open 
Rs.Open "select * from users", Conn, adOpenKeyset, adLockBatchOptimistic 
End Sub