📄 frmdataexport.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Object = "{0B81E4A9-BE4E-4AEF-9272-33AB5B51C6FC}#1.0#0"; "XPControls.ocx"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form FrmDataExport
BackColor = &H00D3DABC&
BorderStyle = 1 'Fixed Single
Caption = "数据导出"
ClientHeight = 3660
ClientLeft = 45
ClientTop = 330
ClientWidth = 6120
Icon = "FrmDataExport.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3660
ScaleWidth = 6120
StartUpPosition = 2 '屏幕中心
Begin MSComDlg.CommonDialog CommonDialog1
Left = 3600
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin ComctlLib.ProgressBar pgbDataExport
Height = 285
Left = 360
TabIndex = 4
Top = 2250
Width = 5415
_ExtentX = 9551
_ExtentY = 503
_Version = 327682
Appearance = 0
Max = 1000
End
Begin XPControls.XPCommandButton CmdOK
Height = 435
Left = 1320
TabIndex = 2
Top = 2880
Width = 1215
_ExtentX = 2143
_ExtentY = 767
Caption = "开始"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.Frame Frame1
BackColor = &H00D3DABC&
Caption = "体检日期"
Height = 825
Left = 330
TabIndex = 1
Top = 870
Width = 5445
Begin MSComCtl2.DTPicker dtpStart
Height = 375
Left = 570
TabIndex = 6
Top = 330
Width = 2085
_ExtentX = 3678
_ExtentY = 661
_Version = 393216
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
CustomFormat = "yyyy-MM-dd HH:mm:ss"
Format = 23789571
CurrentDate = 38157.5236111111
MaxDate = 73415
MinDate = 2
End
Begin MSComCtl2.DTPicker dtpEnd
Height = 375
Left = 3180
TabIndex = 7
Top = 330
Width = 2115
_ExtentX = 3731
_ExtentY = 661
_Version = 393216
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
CustomFormat = "yyyy-MM-dd HH:mm:ss"
Format = 23789571
CurrentDate = 38157
MaxDate = 73415
MinDate = 2
End
Begin VB.Label Label2
BackStyle = 0 'Transparent
Caption = "到"
Height = 225
Left = 2820
TabIndex = 9
Top = 390
Width = 225
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "从"
Height = 195
Left = 210
TabIndex = 8
Top = 420
Width = 255
End
End
Begin XPControls.XPCommandButton CmdExit
Height = 435
Left = 3480
TabIndex = 3
Top = 2880
Width = 1215
_ExtentX = 2143
_ExtentY = 767
Caption = "退出"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.Label LblJD
BackStyle = 0 'Transparent
Caption = "进度"
Height = 285
Left = 450
TabIndex = 5
Top = 1920
Width = 2295
End
Begin VB.Label LblFileName
BackStyle = 0 'Transparent
Caption = "导出文件名"
Height = 405
Left = 450
TabIndex = 0
Top = 270
Width = 5085
End
End
Attribute VB_Name = "FrmDataExport"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim ExportCon As New ADODB.Connection
Dim mstrAccessCon As String
Private Sub cmdExit_Click()
Set ExportCon = Nothing
Unload Me
End Sub
Private Sub cmdOK_Click()
On Error GoTo ErrMsg
Dim Status
Dim rstemp As ADODB.Recordset
Dim i As Integer
Dim strSQL As String
Dim strFileName As String
Dim fso1 As New FileSystemObject
Dim dtmStart As Date
Dim dtmEnd As Date
dtmStart = dtpStart.Value
dtmEnd = dtpEnd.Value & " 23:59:00"
'日期是否合理
If dtmStart > dtmEnd Then
MsgBox "起始日期不能大于终止日期，请重新输入！", vbInformation, "提示"
dtpStart.SetFocus
GoTo ExitLab
End If
'起始日期是否还未到来
If dtmStart > Date Then
MsgBox "您输入的起始日期尚未到来！", vbInformation, "提示"
dtpStart.SetFocus
GoTo ExitLab
End If
'获取文件名
strFileName = GetFileName(Me.CommonDialog1, "ACCESS数据库文档（*.MDB）|*.MDB", "另存为", _
Year(Date) & Month(Date) & Day(Date) & "_" & g_strDevelopCompany & "体检网站数据导出" & ".mdb", WRITEFILE)
If strFileName = "" Then GoTo ExitLab
'将运行目录下的BTTJDataExport.mdb文件拷贝至目的文件一份
fso1.CopyFile gstrCurrPath & "BTTJDataExport.mdb", strFileName, True
'生成ACCESS连接串
mstrAccessCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFileName
If ExportCon Is Nothing Then
Set ExportCon = New ADODB.Connection
Else
If ExportCon.State = adStateOpen Then
ExportCon.Close
End If
End If
ExportCon.ConnectionString = mstrAccessCon
ExportCon.Open
LblFileName.Caption = ""
pgbDataExport.Value = 0
Me.MousePointer = vbHourglass
'取得导出总人数
strSQL = "select count(*) as 导出人数 from SET_GRXX" _
& " where TJRQ>='" & dtmStart & "'" _
& " and TJRQ<='" & dtmEnd & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
If rstemp("导出人数") = 0 Then
MsgBox "所选日期范围内没有需要做导出的数据！请重新设置日期范围。", vbInformation, "提示"
GoTo ExitLab
Else
If MsgBox("网站数据导出可能需要花费一些时间，具体时间视机器配置以及导出的数据量而定。" & vbCrLf _
& "您确认要导出吗？", vbQuestion + vbOKCancel + vbDefaultButton1, _
"导出提示") = vbOK Then
'ExportData dtmStart, dtmEnd, App.Path
Call ExportDataW(dtmStart, dtmEnd)
End If
End If
GoTo ExitLab
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
ExitLab:
Me.MousePointer = vbDefault
End Sub
Private Sub Form_Load()
pgbDataExport.Value = 0
dtpStart.Value = Date
dtpEnd.Value = Date
End Sub
'导出指定日期范围的数据
Private Sub ExportDataW(ByVal dtmStart As Date, ByVal dtmEnd As Date)
Dim strSQL As String
Dim rstemp As ADODB.Recordset
Dim lngExportCount As Long
'首先清除BTTJDataExport.mdb中的数据
ClearBTTJDataExport
DoEvents
'第一步，导出科室设置
If ExportKSSZ = False Then GoTo ExitLab
DoEvents
'第二步，导出所有组合
If ExportDX = False Then GoTo ExitLab
DoEvents
'第三步，导出所有项目
If ExportXX = False Then GoTo ExitLab
DoEvents
'第四步，导出所有对应关系
If ExportZH = False Then GoTo ExitLab
DoEvents
'第五步，导出体检标准
If ExportTJBZ = False Then GoTo ExitLab
DoEvents
'第六步，循环处理所选日期范围的所有客户
strSQL = "select GUID from SET_GRXX" _
& " where TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
If Not rstemp.EOF Then
pgbDataExport.Min = 0
pgbDataExport.Max = IIf(rstemp.RecordCount = 1, 2, rstemp.RecordCount)
pgbDataExport.Min = 1
Do While Not rstemp.EOF
Call ExportPersonData(rstemp("GUID"))
pgbDataExport.Value = lngExportCount + 1
lngExportCount = lngExportCount + 1
LblJD.Caption = "当前进度 " & lngExportCount & "/" & rstemp.RecordCount
DoEvents
rstemp.MoveNext
Loop
rstemp.Close
End If
Set rstemp = Nothing
'提示
MsgBox "导出完毕！", vbInformation, "提示"
GoTo ExitLab
ExitLab:
'
End Sub
'导出科室设置
Private Function ExportKSSZ() As Boolean
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim rstemp As ADODB.Recordset
'提取所有科室
strSQL = "select * from SET_KSSZ"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
If Not rstemp.EOF Then
Do While Not rstemp.EOF
'循环把所以数据导出
strSQL = "insert into SET_KSSZ(KSID,KSMC,KSSM,KSPYSX,KSWBSX,SXH)" _
& " values(" _
& "'" & rstemp("KSID") & "'" _
& ",'" & rstemp("KSMC") & "'" _
& ",'" & rstemp("KSSM") & "'" _
& ",'" & rstemp("KSPYSX") & "'" _
& ",'" & rstemp("KSWBSX") & "'" _
& "," & rstemp("SXH") _
& ")"
ExportCon.Execute strSQL
rstemp.MoveNext
Loop
rstemp.Close
End If
Set rstemp = Nothing
ExportKSSZ = True
GoTo ExitLab
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
ExitLab:
'
End Function
'导出所有组合
Private Function ExportDX() As Boolean
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim rstemp As ADODB.Recordset
'提取所有组合
strSQL = "select * from SET_DX"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
If Not rstemp.EOF Then
Do While Not rstemp.EOF
'循环把所以数据导出
strSQL = "insert into SET_DX(DXID,DXMC,KSID,DXPYSX,DXWBSX,DXSM,DXJG,DXNNTY,SXH)" _
& " values(" _
& "'" & rstemp("DXID") & "'" _
& ",'" & rstemp("DXMC") & "'" _
& ",'" & rstemp("KSID") & "'" _
& ",'" & rstemp("DXPYSX") & "'" _
& ",'" & rstemp("DXWBSX") & "'" _
& ",'" & rstemp("DXSM") & "'" _
& "," & rstemp("DXJG") _
& "," & rstemp("DXNNTY") _
& "," & rstemp("SXH") _
& ")"
ExportCon.Execute strSQL
rstemp.MoveNext
Loop
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -