|
7#
楼主 |
发表于 2008-2-2 17:45:03
|
只看该作者
在窗体中引用数据导出函数
Private Sub cmd_export_qichu_Click()
Dim frm As Object
set frm = revenue_cost_data_import '将窗体名赋值给变量
On Error GoTo err_cmd_export_qichu
exportExportData frm,straction, "期初分摊率基础数据模板"
exit_cmd_export_qichu:
Exit Sub
err_cmd_export_qichu:
MsgBox Err.Description
Resume exit_cmd_export_qichu
End Sub
'在数据导出函数中引用另一个进度条函数
Public Function exportExportData(frm as form,straction As String, _
Optional strObject As String = "", Optional intType As Integer) As Boolean
Dim Conn As ADODB.Connection
Dim Rs As ADODB.Recordset
Set Conn = CurrentProject.Connection
Set Rs = CreateObject("ADODB.Recordset")
Rs.Open straction, Conn, 1
FunProGressBar frm, 0, Rs.RecordCount
' Called from ImportExport form
On Error GoTo HandleErr
' Turn off screen updating
Application.Echo False
' If we're exporting, open the object
DoCmd.OpenTable strObject, acViewNormal
' Kick off the action the user has chosen
DoCmd.RunCommand acCmdOutputToExcel
DoCmd.Close
exportExportData = True
ExitHere:
Application.Echo True
Exit Function
HandleErr:
exportExportData = False
Select Case Err
Case 2501 ' User cancelled
Resume ExitHere
Case Else
MsgBox Err & ": " & Err.Description & "错误发生在数据导出函数", vbOKOnly + vbCritical, "系统提示"
Resume ExitHere
End Select
End Function
'在这个进度条函数中需要对窗体中的一些控制的属性赋值
Public Function FunProGressBar(frm As Form, ByVal RecValue, ByVal RecMax, Optional TempText As String)
' Dim TempProWidth As Integer ' ''进度条总长
Dim Temptimes As Long ''进度时间
Dim TempCounttime As Double ''时间总长度
Dim ShowTimes As String ''显示的时间,以分;秒结束
Const TempProWidth = 5790 ''进度条总长
On Error GoTo Err:
If RecValue = 1 Then TempTimeon = Now
If RecValue > RecMax Then Exit Function
DoEvents
With frm
.proportion.Caption = Round(RecValue / RecMax, 2) * 100 & "%"
.TempText.Caption = "分析"
.Temptimes = DateDiff("s", TempTimeon, Now) / RecValue * (RecMax - RecValue)
If RecValue > 1 Then .RunTime.Caption = "大约剩余 " & ShowTimes
If RecValue = RecMax Then .TempCounttime = DateDiff("s", TempTimeon, Now)
End With
End Function |
|