程序代码：

Public access As New ADODB.Connection
Public res As New ADODB.Recordset
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Private Sub Command1_Click()
Dim str As String
Dim sql As String
str = Text1.Text
res.Close
sql = "SELECT * FROM ziliao where 商品名 like '%" & Text1 & "%'  ORDER BY 编号"
res.Open sql, access, 1, 3
Set DataGrid1.DataSource = res
res.Close
End Sub

Private Sub Command2_Click()
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen() As Integer
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

sql = "SELECT * FROM ziliao ORDER BY 编号"
res.Open sql, access, 1, 3
Set DataGrid1.DataSource = res
With res
Irowcount = .RecordCount '记录总数
Icolcount = .Fields.Count '字段总数
ReDim Fieldlen(Icolcount) As Integer
res.MoveFirst
For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
Case 1 '在Excel中的第一行加标题

xlSheet.Cells(Irow, Icol).Value = RTrim(.Fields(Icol - 1).Name)
Case 2 '将数组FIELDLEN()存为第一条记录的字段长
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(RTrim(.Fields(Icol - 1).Name))
Else
aa = RTrim(.Fields(Icol - 1).Name)
Fieldlen(Icol) = LenB(aa)
End If
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
xlSheet.Cells(Irow, Icol).Value = RTrim(.Fields(Icol - 1))
Case Else
Fieldlen1 = LenB(.Fields(Icol - 1))
If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
Fieldlen(Icol) = Fieldlen1
Else
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
End If
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
End Select
Next
If Irow <> 1 Then
If Not .EOF Then .MoveNext
End If
Next
'    With xlSheet
'   .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
'   .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
'   .Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
'    End With
'xlApp.Visible = True
Dim aaa
aaa = MsgBox("是否保存该Excel表?", vbYesNo, "提示窗口")
If aaa = vbYes Then
CommonDialog1.FileName = "报表"
CommonDialog1.Filter = "Xls文件(*.Xls)|*.Xls|所有文件(*.*)|*.*"
CommonDialog1.ShowSave
On Error GoTo ErrSave
NewSheet.SaveAs CommonDialog1.FileName
' MsgBox "保存成功"
newxls.Quit
ErrSave:
Exit Sub
MsgBox Err.Description, , "提示窗口"
End If
Set xlApp = Nothing
End With
End Sub

Private Sub Form_Load()

m = 0
If Dir(App.Path + "\资料.mdb") <> "" Then
    access.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "\资料.mdb;Persist Security Info=False;Jet OLEDB:Database Password=123"
    access.Open
         
    Set res.ActiveConnection = access '设置rs1的ActiveConnection属性，指定与其关联的数据库连接
    
    res.CursorLocation = adUseClient  '设置游标类型

    res.CursorType = adOpenDynamic '设置动态游标
    res.Open "SELECT * FROM ziliao ORDER BY 编号", access, 1, 3  '打开记录集，将从表Departments中读取的结果集保存到记录集res中
       DataGrid1.Refresh  '刷新表格
    Set DataGrid1.DataSource = res '将DataSource连接到数据库
    res.MoveFirst     
Else
  MsgBox "找不到数据库"
  
End If
res.Close
End Sub