frmdataexport.frm

本系统可用于医院和专业体检中心的健康体检管理

'    lngExportCount = 0
'    '开始导出数据
'    Set rsTemp = New ADODB.Recordset
'    rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'    If rsTemp.RecordCount > 0 Then
'        pgbDataExport.Min = 0
'        pgbDataExport.Max = IIf(rsTemp.RecordCount = 1, 2, rsTemp.RecordCount)
'        pgbDataExport.Min = 1
'
'        '首先清除BTTJDataExport.mdb中的数据
'        ClearBTTJDataExport
'        rsTemp.MoveFirst
'        '循环导出全部数据
'        Do While Not rsTemp.EOF
'            ExportGUID rsTemp("GUID")
'            pgbDataExport.Value = lngExportCount + 1
'            lngExportCount = lngExportCount + 1
'            LblJD.Caption = "当前进度  " & lngExportCount & "/" & rsTemp.RecordCount
'
'            DoEvents
'            rsTemp.MoveNext
'        Loop
'        MsgBox "导出完毕!", vbInformation, "提示"
'    Else
'        MsgBox "没有可供导出的数据!", vbInformation, "提示"
'    End If
'
'    GoTo ExitLab
'ErrMsg:
'    Status = SetError(Err.Number, Err.Description, Err.Source)
'    ErrMsg Status
'ExitLab:
'    '
'End Sub

'清除BTTJDataExport中的全部数据
Public Sub ClearBTTJDataExport()
    Dim strSQL As String
    
    '清除Person_XX
    strSQL = "delete * from Person_XX"
    ExportCon.Execute strSQL
    
    '清除SET_DX
    strSQL = "delete * from SET_DX"
    ExportCon.Execute strSQL
    
    '清除SET_KSSZ
    strSQL = "delete * from SET_KSSZ"
    ExportCon.Execute strSQL
    
    '清除SET_TJBZDT
    strSQL = "delete * from SET_TJBZDT"
    ExportCon.Execute strSQL
    
    '清除SET_XX
    strSQL = "delete * from SET_XX"
    ExportCon.Execute strSQL
    
    '清除SET_ZH_Data
    strSQL = "delete * from SET_ZH_Data"
    ExportCon.Execute strSQL
    
    '清除XMResult
    strSQL = "delete * from XMResult"
    ExportCon.Execute strSQL
    
    '清除YY_SJDJDX
    strSQL = "delete * from YY_SJDJDX"
    ExportCon.Execute strSQL
    
    '清除ZJResult
    strSQL = "delete * from ZJResult"
    ExportCon.Execute strSQL
End Sub

''导出一个GUID的数据
'Public Sub ExportGUID(ByVal lngGUID As Long)
 '针对每个用户捕获错误
'    Dim Status
'    Dim rsTemp As ADODB.Recordset
'    Dim cmdTemp As ADODB.Command
'    Dim rsTempDX As ADODB.Recordset
'    Dim rsTempXX As ADODB.Recordset
'    Dim rsTemp1 As ADODB.Recordset
'    Dim rsTemp2 As ADODB.Recordset
'    Dim rsBZ As ADODB.Recordset '体检标准
'
'    Dim strTmpYYID As String
'    Dim strTmpDXPYSX As String
'    Dim strSQL As String
'    Dim intFZID As Integer
'
'    Dim TmpclsDisk As New CDiskInfo
'    Dim strTmpQueryCode As String
'
'    strSQL = "select * from SET_GRXX where GUID=" & lngGUID
'    Set rsTemp = New ADODB.Recordset
'    rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'    With TmpPersonXX
'        If IsNull(rsTemp("AGE")) Then
'            .AGE = 0
'        ElseIf rsTemp("AGE") = "" Then
'            .AGE = 0
'        Else
'            .AGE = rsTemp("AGE")
'        End If
'        .GUID = lngGUID
'        .HEALTHID = rsTemp("HealthID")
'        .TJSerialNum = rsTemp("TJSerialNum")
'        .EMail = rsTemp("Email") & ""
'        .HF = rsTemp("HF") & ""
'        .LXDZ = rsTemp("LXDZ") & ""
'        .YZBM = rsTemp("YZBM") & ""
'        .TJRQ = rsTemp("TJRQ")
'        .name = rsTemp("YYRXM")
'        .SEX = rsTemp("Sex")
'        '取得该人的查询码
''        strTmpQueryCode = TmpclsDisk.GetFixedSerialNumber(rsTemp("YYRXM") & rsTemp("HealthID"), 8)
'        strTmpQueryCode = LongToString(rsTemp("GUID"), 6) & TmpclsDisk.GetFixedSerialNumber(rsTemp("GUID") & rsTemp("HealthID"), 8)
'        .QueryCode = strTmpQueryCode
'    End With
'
'    TmpPersonXX.DanWei = "" '首先设置为空
'    If (Not IsNull(rsTemp("YYID"))) And (rsTemp("YYID") <> "") Then
'        '从该人的预约ID查该人对应的单位名称
'        strSQL = "select DWMC from YY_TJDJ,SET_DW where" _
'                & " YY_TJDJ.YYID='" & rsTemp("YYID") & "'" _
'                & " and YY_TJDJ.DWID=SET_DW.DWID"
'        Set rsTemp1 = New ADODB.Recordset
'        rsTemp1.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
'        If Not rsTemp1.EOF Then
'            If Not IsNull(rsTemp1("DWMC")) Then
'                '有单位时设置为所属单位
'                TmpPersonXX.DanWei = rsTemp1("DWMC")
'            End If
'            rsTemp1.Close
'        End If
'    End If
'    rsTemp.Close
'
'    '将该GUID信息插入BTTJExportData.mdb的Person_XX表中
'    Call InsertPersonXX(TmpPersonXX)
'
'    '查找该人所选的项目
'    strSQL = "select SET_DX.DXID,SET_DX.DXPYSX from YY_SJDJDX,SET_DX" _
'            & " where YY_SJDJDX.GUID=" & lngGUID _
'            & " and YY_SJDJDX.DXID=SET_DX.DXID"
'    Set rsTemp = New ADODB.Recordset
'    rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'    If rsTemp.RecordCount > 0 Then
'        '循环所有大项,从SET_DX表中查该大项是否有子项
'        rsTemp.MoveFirst
'        Do While Not rsTemp.EOF
'            strTmpDXPYSX = rsTemp("DXPYSX")
'
'            '从SET_XX表中找出当前大项所包含的所有小项
'            strSQL = "select XXID,XXMC,XXPYSX,XXNNTY from SET_XX" _
'                    & " where XXID in (" _
'                        & " select XXID from SET_ZH_Data" _
'                        & " where DXID='" & rsTemp("DXID") & "'" _
'                    & ")"
'            Set rsTempXX = New ADODB.Recordset
'            rsTempXX.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'            '如果该大项包含小项
'            If rsTempXX.RecordCount > 0 Then
'                rsTempXX.MoveFirst
'                Do While Not rsTempXX.EOF
'                    '记录当前小项的拼音缩写
'                    strTmpXXPYSX = rsTempXX("XXPYSX")
'
'                    '如果该小项还未进入BTTJExportData.mdb的XMIndex表,则在该表中插入一条记录
'                    If Not IfExistXM(rsTempXX("XXID")) Then
'                        strSQL = "select * from SET_TJBZDT" _
'                                & " where XMID='" & rsTempXX("XXID") & "'" _
'                                & " and BZID=" & g_intEnableBZID
'                        Set rsBZ = New ADODB.Recordset
'                        rsBZ.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'                        With TmpXMIndex
'                            .XMID = rsTempXX("XXID")
'                            .XMMC = rsTempXX("XXMC")
'                            If rsBZ.EOF Then
'                                .CKSX = ""
'                                .CKXX = ""
'                                .XMDW = ""
'                            Else
'                                .CKSX = rsBZ("CKSX") & ""
'                                .CKXX = rsBZ("CKXX") & ""
'                                .XMDW = rsBZ("DW") & ""
'                                rsBZ.Close
'                            End If
'                            .XMType = rsTempXX("XXNNTY")
'                        End With
'                        Call InsertXMIndex(TmpXMIndex)
'                    End If
'
'                    '获得该GUID在该项目上的检查值
'                    Set rsTemp1 = New ADODB.Recordset
'                    strSQL = "select [" & strTmpXXPYSX & "] from [DATA_" & strTmpDXPYSX & "]" _
'                            & " where GUID='" & lngGUID & "'"
'                    rsTemp1.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'                    '如果存在，则将检查值插入BTTJExportData.mdb的ExportData表
'                    If Not rsTemp1.EOF Then
'                        With TmpExportData
'                            .QueryCode = strTmpQueryCode
'                            .XMID = rsTempXX("XXID")
'                            .XMValue = rsTemp1(strTmpXXPYSX) & ""
'                        End With
'                        Call InsertExportData(TmpExportData)
'                    End If
'
'                    rsTempXX.MoveNext
'                Loop
'            End If
'
'            rsTemp.MoveNext
'        Loop
'    End If
'
'
'    '插入总检结论和总检建议
'    Call InsertJLJY(lngGUID, strTmpQueryCode)
'
'    '将该GUID的SET_GRXX表中Export字段设为1
'    Set cmdTemp = New ADODB.Command
'    Set cmdTemp.ActiveConnection = GCon
'    strSQL = "update SET_GRXX set Export=1 where GUID=" & lngGUID
'    cmdTemp.CommandText = strSQL
'    cmdTemp.Execute
'
'    GoTo ExitLab
'ErrMsg:
'    Status = SetError(Err.Number, Err.Description, Err.Source)
'    ErrMsg Status
'ExitLab:
'    '
'End Sub
'
'Private Sub InsertPersonXX(TmpPersonXX As PersonXX)
'    Dim cmdTemp As ADODB.Command
'    Dim strSQL As String
'    Dim rsTemp As New ADODB.Recordset
'
''    Set cmdTemp = New ADODB.Command
''    Set cmdTemp.ActiveConnection = ExportCon
'    '新插入一条空记录
''    strSql = "insert into Person_XX(GUID,QueryCode,HealthID,TJSerialNum,TJRQ,Name,Sex,HF,Age,Email,LXDZ,YZBM) " _
''             & "values(" & TmpPersonXX.GUID _
''             & ",'" & TmpPersonXX.QueryCode _
''             & ",'" & TmpPersonXX.HealthID & "'" _
''             & "," & Val(TmpPersonXX.TJSerialNum) _
''             & ",'" & TmpPersonXX.TJRQ & "'" _
''             & ",'" & TmpPersonXX.Name & "'" _
''             & ",'" & TmpPersonXX.Sex & "'" _
''             & ",'" & TmpPersonXX.HF & "'" _
''             & "," & TmpPersonXX.Age _
''             & ",'" & TmpPersonXX.EMail & "'" _
''             & ",'" & TmpPersonXX.LXDZ & "'" _
''             & ",'" & TmpPersonXX.YZBM & "')"
''    strSql = "INSERT INTO Person_XX(GUID) Values(" & TmpPersonXX.GUID & ")"
''    cmdTemp.CommandText = strSql
''    cmdTemp.Execute
'
''    '开始更新个人信息
''    strSql = "update Person_XX set" _
''            & " QueryCode='" & TmpPersonXX.QueryCode & "'" _
''            & ",HealthID='" & TmpPersonXX.HealthID & "'" _
''            & ",TJSerialNum=" & Val(TmpPersonXX.TJSerialNum) _
''            & ",TJRQ='" & TmpPersonXX.TJRQ & "'" _
''            & ",Name='" & TmpPersonXX.Name & "'" _
''            & ",SEX='" & TmpPersonXX.Sex & "'" _
''            & ",HF='" & TmpPersonXX.HF & "'" _
''            & ",AGE=" & TmpPersonXX.Age _
''            & ",EMail='" & TmpPersonXX.EMail & "'" _
''            & ",LXDZ='" & TmpPersonXX.LXDZ & "'" _
''            & ",YZBM='" & TmpPersonXX.YZBM & "'" _
''            & " where GUID='" & TmpPersonXX.GUID & "'"
''    cmd.CommandText = strSql
''    cmd.Execute
'    rsTemp.Open "select * from Person_XX ", ExportCon, adOpenDynamic, adLockOptimistic
'    rsTemp.AddNew
'    rsTemp("GUID") = TmpPersonXX.GUID
'    rsTemp("QueryCode") = TmpPersonXX.QueryCode
'    rsTemp("HealthID") = TmpPersonXX.HEALTHID
'    rsTemp("TJSerialNum") = TmpPersonXX.TJSerialNum
'    rsTemp("TJRQ") = TmpPersonXX.TJRQ
'    rsTemp("Name") = TmpPersonXX.name
'    rsTemp("SEX") = TmpPersonXX.SEX
'    rsTemp("HF") = TmpPersonXX.HF
'    If TmpPersonXX.AGE > 0 Then
'        rsTemp("AGE") = TmpPersonXX.AGE
'    End If
'    rsTemp("EMail") = TmpPersonXX.EMail
'    rsTemp("LXDZ") = TmpPersonXX.LXDZ
'    rsTemp("YZBM") = TmpPersonXX.YZBM
'
'    rsTemp.Update
'
'ExitLab:
'End Sub
'
'Private Sub InsertExportData(TmpExportData As ExportData)
'    Dim cmdTemp As ADODB.Command
'    Dim strSQL As String
'
'    Set cmdTemp = New ADODB.Command
'    Set cmdTemp.ActiveConnection = ExportCon
'    '新插入一条空记录
'    strSQL = "insert into ExportData(QueryCode,XMID,XMValue) values('" _
'             & TmpExportData.QueryCode & "'" _
'             & ",'" & TmpExportData.XMID & "'" _
'             & ",'" & TmpExportData.XMValue & "')"
'    cmdTemp.CommandText = strSQL
'    cmdTemp.Execute
'ExitLab:
'End Sub
'
'Private Sub InsertXMIndex(TmpXMIndex As XMIndex)
'    Dim cmdTemp As ADODB.Command
'    Dim strSQL As String
'
'    Set cmdTemp = New ADODB.Command
'    Set cmdTemp.ActiveConnection = ExportCon
'    '新插入一条空记录
'    strSQL = "insert into XMIndex(XMID,XMMC,XMType,CKSX,CKXX,XMDW) values('" _
'             & TmpXMIndex.XMID & "'" _
'             & ",'" & TmpXMIndex.XMMC & "'" _
'             & "," & TmpXMIndex.XMType _
'             & ",'" & TmpXMIndex.CKSX & "'" _
'             & ",'" & TmpXMIndex.CKXX & "'" _
'             & ",'" & TmpXMIndex.XMDW & "')"
'    cmdTemp.CommandText = strSQL
'    cmdTemp.Execute
'End Sub
'
''插入某人的总检结论和建议
'Private Sub InsertJLJY(lngGUID As Long, ByVal strCXM As String)
'On Error GoTo ExitLab
'    Dim cmdTemp As ADODB.Command
'    Dim strSQL As String
'    Dim rsTemp As ADODB.Recordset
'    Dim strTmpZJJL, strTmpZJJY As String
'
'    '取得总检结论
'    Set rsTemp = New ADODB.Recordset
'    strSQL = "select JLValue from DATA_ZJJL" _
'            & " where GUID=" & lngGUID
'    rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'    If Not rsTemp.EOF Then
'        strTmpZJJL = rsTemp("JLValue") & ""
'        rsTemp.Close
'    End If
'
'    '取得总检建议
'    Set rsTemp = New ADODB.Recordset
'    strSQL = "select JYValue from DATA_ZJJY" _
'            & " where GUID=" & lngGUID
'    rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'    If Not rsTemp.EOF Then
'        strTmpZJJY = rsTemp("JYValue")
'        rsTemp.Close
'    End If
'
'    '在ACCESS数据库中插入记录
'    If strTmpZJJL = "" Then
'        strTmpZJJL = "未见异常"
'    End If
'    If strTmpZJJY = "" Then
'        strTmpZJJY = "正常"
'    End If
'    strSQL = "insert into JLJY values(" & lngGUID & ",'" & strCXM & "'" _
'            & ",'" & strTmpZJJL & "','" & strTmpZJJY & "')"
'    Set cmdTemp = New ADODB.Command
'    Set cmdTemp.ActiveConnection = ExportCon
'    cmdTemp.CommandText = strSQL
'    cmdTemp.Execute
'ExitLab:
'
'End Sub
'
''检索一个小项在access数据库中是否已经存在
'Private Function IfExistXM(ByVal strXMID As String) As Boolean
'    Dim rsTemp As New ADODB.Recordset
'    Dim strSQL As String
'
'    strSQL = "select Count(*) from XMIndex where XMID='" & strXMID & "'"
'    rsTemp.Open strSQL, ExportCon, adOpenForwardOnly, adLockReadOnly
'    If rsTemp(0) > 0 Then
'        IfExistXM = True
'    Else
'        IfExistXM = False
'    End If
'    rsTemp.Close
'    Set rsTemp = Nothing
'End Function