[code=VB]
Dim s1, s2
s1 = DTPicker1.Value
s2 = DTPicker2.Value
On Error GoTo ErrorHandler
' If fcFileExists(App.Path & "/db1.mdb") = False Then '文件如果存在就继续(文件不存在就退出)
' Call MsgBox("当前路径下<db1.mdb>文件不存在! ", vbOKOnly + vbCritical, "错误提示:")
' GoTo Exit_Sub
If fcFileExists("D:/报表/报表.xls ") = False Then
If MsgBox("当前路径下<报表.xls>文件不存在!是否创建Excle文件后再导出? ", vbYesNo + vbCritical, "错误提示:") = vbYes Then
Call cmdCreateXLS_Click '建立新的XLS文件
End If
End If
'----------------------------------
'② 用ADO在Access文件中检索数据
'----------------------------------
Dim Conn As ADODB.Connection '定义ADODB连接的对象
Dim Record As ADODB.Recordset '定义ADODB对象的记录集
Dim ConnStr As String '定义连接字符串
Set Conn = New ADODB.Connection '给对象分配空间
Set Record = New ADODB.Recordset
ConnStr = "Provider=SQLOLEDB.1;User ID=sa;password=sa;Initial Catalog=abc;Data Source=(local)"
Conn.ConnectionString = ConnStr '按照[连接字符串]的内容连接数据库
Conn.Open '连接
If Combo1 = "" And Text1 = "" Then
Record.Open "Select 编号,送货单编号,kehu as 客户,xingming as 姓名,wupin as 物品,danwei as 单位,shuliang as 数量,danjia as 单价,jine as 金额,beizhu as 备注,date as 日期,yewuyuan as 业务员 From biao where Date between # " & s1 & " # and # " & s2 & " # ", Conn, adLockReadOnly, adLockReadOnly
ElseIf Combo1 = "" And Text1 <> "" Then Record.Open "Select 编号,送货单编号,kehu as 客户,xingming as 姓名,wupin as 物品,danwei as 单位,shuliang as 数量,danjia as 单价,jine as 金额,beizhu as 备注,date as 日期,yewuyuan as 业务员 From biao where wupin like '%" & Text1.Text & "%' and Date between # " & s1 & " # and # " & s2 & " # ", Conn, adLockReadOnly, adLockReadOnly '检索数据
ElseIf Combo1 <> "" And Text1 = "" Then Record.Open "Select 编号,送货单编号,kehu as 客户,xingming as 姓名,wupin as 物品,danwei as 单位,shuliang as 数量,danjia as 单价,jine as 金额,beizhu as 备注,date as 日期,yewuyuan as 业务员 From biao where xingming='" & Combo1.Text & "' and Date between # " & s1 & " # and # " & s2 & " # ", Conn, adLockReadOnly, adLockReadOnly '检索数据
Else
Record.Open "Select 编号,送货单编号,kehu as 客户,xingming as 姓名,wupin as 物品,danwei as 单位,shuliang as 数量,danjia as 单价,jine as 金额,beizhu as 备注,date as 日期,yewuyuan as 业务员 From biao where xingming='" & Combo1.Text & "' and wupin like '%" & Text1.Text & "%'and Date between # " & s1 & " # and # " & s2 & " # ", Conn, adLockReadOnly, adLockReadOnly '检索数据
End If
If Combo2 <> "" And Text1 = "" Then
Record.Open "Select 编号,送货单编号,kehu as 客户,xingming as 姓名,wupin as 物品,danwei as 单位,shuliang as 数量,danjia as 单价,jine as 金额,beizhu as 备注,date as 日期,yewuyuan as 业务员 From biao where yewuyuan='" & Combo2.Text & "' and Date between # " & s1 & " # and # " & s2 & " # ", Conn, adLockReadOnly, adLockReadOnly
ElseIf Combo2 <> "" And Text1 <> "" Then Record.Open "Select 编号,送货单编号,kehu as 客户,xingming as 姓名,wupin as 物品,danwei as 单位,shuliang as 数量,danjia as 单价,jine as 金额,beizhu as 备注,date as 日期,yewuyuan as 业务员 From biao where yewuyuan='" & Combo2.Text & "' and wupin like '%" & Text1.Text & "%' and Date between # " & s1 & " # and # " & s2 & " # ", Conn, adLockReadOnly, adLockReadOnly '检索数据
ElseIf Combo2 <> "" And Combo1 <> "" Then Record.Open "Select 编号,送货单编号,kehu as 客户,xingming as 姓名,wupin as 物品,danwei as 单位,shuliang as 数量,danjia as 单价,jine as 金额,beizhu as 备注,date as 日期,yewuyuan as 业务员 From biao where xingming='" & Combo1.Text & "' and yewuyuan='" & Combo2.Text & "' and Date between # " & s1 & " # and # " & s2 & " # ", Conn, adLockReadOnly, adLockReadOnly '检索数据
End If
'----------------------------------
'③ 导出到Excel文件中 and wupin like '%" & Text5.Text & "%'
'----------------------------------
Dim rstCount As Long '记录行数
Dim rstField As Long '记录列数
rstCount = Record.RecordCount
rstField = Record.Fields.Count
Dim mExApp As Excel.Application '应用
Dim mExBook As Excel.Workbook '工作薄
Dim mExSheet As Excel.Worksheet '工作表
Set mExApp = CreateObject("Excel.Application")
Set mExBook = mExApp.Workbooks.Open("D:/报表/报表.xls")
Set mExSheet = mExBook.Worksheets(1)
Dim lLine As Long
Dim Column As Long
Dim sCellValue As String
lLine = 1
'写列头
For Column = 0 To rstField - 1
sCellValue = Record.Fields(Column).Name
mExSheet.Cells(lLine, Column + 1) = sCellValue
Next Column
DoEvents '给下一个执行让"道"
Me.MousePointer = vbHourglass
Me.Enabled = False
'开始内容
For lLine = 2 To rstCount + 1
For Column = 0 To rstField - 1
sCellValue = Record.Fields(Column)
mExSheet.Cells(lLine, Column + 1) = sCellValue
Next Column
Record.MoveNext '下一行数据
Next lLine
'自动调整列
For Column = 1 To rstField
mExSheet.Columns(Column).AutoFit
Next
'输出该表
mExBook.Save '保存
mExBook.Close (True) '按内容变化关闭
Dim IsOK As Boolean '成功导入状态标记
IsOK = True '通过此状态判断是否提示消息
GoTo Exit_Sub '创建XLS文件后退出
Exit_Sub:
mExBook.Close (False) '不按内容变化关闭
mExApp.Quit '关闭创建的文件
Set mExBook = Nothing
Set mExApp = Nothing
Set mExSheet = Nothing
If Not (Record Is Nothing) Then
Record.Close
Set Record = Nothing
End If
Me.MousePointer = vbDefault
Me.Enabled = True
If IsOK = True Then MsgBox "导出成功!", vbOKOnly + vbInformation, "消息:"
Call cmdOpenFolder_Click
Exit Sub
ErrorHandler:
If Err.Number = 1004 Then GoTo Exit_Sub
Resume Next '(如果mExBook已经关闭,执行mExApp.Quit)[/code]
自己的一个程序 以前是连ACCESS的
现在把它改成连SQL2000 所有页面都改好了
唯一不会的就是输出到EXCEL了
上面是以前ACCESS输出到EXCEL的全部代码
请高手告诉我要怎么改呢