module1.bas

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

    Dim Status
    Dim strSQL As String
    Dim strFileName As String
    Dim strExport As String
    Dim rstemp As ADODB.Recordset
    Dim rsTmpTJXH As ADODB.Recordset
    Dim i As Integer
    Dim strTmpHealthID
    Dim blnCheck As Boolean        '标识EXCEL文件中的所填卡的验证有效性，有一个卡不对应，则该文件无效
    Dim lngGUID As Long
    Dim intTJXH As Integer
    Dim datFZTJRQ As Date '所选分组的体检日期
    
    Dim ObjExcel As Excel.Application '定义Excel对象
    Dim ObjWorkBook As Excel.Workbook '定义工作薄
    Dim ObjSheet As Excel.Worksheet '定义工作表
    Dim ObjRange As Excel.Range '定义用户使用工作表的范围
  
    Dim tmpFZID As Integer          '标识该体检者进入的分组
    Dim strDuplicatePersons As String  '重复名单
    Dim strFindSFZHPersons As String '身份证号码已经在数据库里面存在的人员名单
    Dim lngMsgBoxRet As VbMsgBoxResult
    Dim blnNewPerson As Boolean '是否是第一次来。在写入健康档案时使用
    Dim strSelfBH As String
    
    Screen.MousePointer = vbHourglass
    
    '首先判断该单位是否已建立了分组,若没有,则不进行导入
    Set rstemp = New ADODB.Recordset
    rstemp.Open "select Count(*) from FZ_FZSY where YYID='" & inYYID & "'", GCon, adOpenStatic, adLockReadOnly
    If rstemp(0) = 0 Then
        MsgBox "该单位还未建立分组,请先建立分组", vbInformation, "提示"
        GoTo ExitLab
    End If
    rstemp.Close
    
    Set ObjExcel = New Excel.Application
    Set ObjWorkBook = ObjExcel.Workbooks.Open(inFileName) '打开EXCEL文件
    Set ObjSheet = ObjWorkBook.ActiveSheet
    
    blnCheck = True '初始化
    With ObjSheet
        '***********************************************************************
        '                           校验文件的合法性
        '***********************************************************************
        For i = 2 To .UsedRange.Rows.Count  'ObjSheet.UsedRange.Rows.Count是当前表的行数
            If Trim(.Cells(i, intICKNumCol)) <> "" _
                    And Not IsNull(.Cells(i, intICKNumCol)) Then
                '第一步，存在卡号时，判断卡号是否已经存在
                strSQL = "select * from SET_ICKGL_Index" _
                        & " where ICKNum='" & Trim(.Cells(i, intICKNumCol)) & "'"
                Set rstemp = New ADODB.Recordset
                rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                If rstemp.RecordCount > 0 Then      '说明该卡已发出
                    strTmpHealthID = rstemp("HealthID")
                    rstemp.Close
                    '检查该卡的所有人是否与EXCEL表中的人相符
                    strSQL = "select YYRXM from SET_GRXX" _
                            & " where HealthID='" & strTmpHealthID & "'"
                    Set rstemp = New ADODB.Recordset
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    If rstemp.RecordCount > 0 Then
                        If Trim(.Cells(i, intNameCol)) <> rstemp("YYRXM") Then
                            '说明在EXCEL表中的人的卡号已被其他人占用，需要给EXCEL表中的人重新发卡
                            MsgBox .Cells(i, intNameCol) & "(第 " & i & " 行) 的卡号已被客户 “" _
                                    & rstemp("YYRXM") & "” 使用，请修改 " & inFileName & " 中该人的卡号", vbInformation, "提示"
                            blnCheck = False    '该文件无效，需要修改
                            GoTo ExitLab
                        End If
                        rstemp.Close
                    End If
                Else
                    '卡号尚未被使用
                    '检查是否自动分配模式
                    If GSelfNumberAuto.Auto Then
                        MsgBox "当前自定义档案号采用的是自动分配模式。您给客户“" _
                                & .Cells(i, intNameCol) & "(第" & i & "行)”分配了一个新号码，这与系统设置相冲突。" _
                                & vbCrLf & "可能的原因是号码录入错误，或者姓名录入错误。" & vbCrLf & "如果您打算手工分配号码，" _
                                & "请在“系统设置”->“系统参数”里面修改“基本参数”。", vbInformation, "提示"
                        blnCheck = False
                        GoTo ExitLab
                    End If
                End If
            Else
                '第二步，不存在卡号的时候，判断身份证号是否已经存在
                If Trim(.Cells(i, intSFZHCol)) <> "" And Not IsNull(.Cells(i, intSFZHCol)) Then
                    strSQL = "select YYRXM from SET_GRXX" _
                            & " where YYRSFZH='" & Trim(.Cells(i, intSFZHCol)) & "'"
                    Set rstemp = New ADODB.Recordset
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    If Not rstemp.EOF Then
                        '找到匹配记录
                        '检查是否同一个人
                        If rstemp("YYRXM") <> Trim(.Cells(i, intNameCol)) Then
                            '提示是否修改数据库中的名字
                            lngMsgBoxRet = MsgBox("在数据库中找到身份证号“" & .Cells(i, intSFZHCol) _
                                    & "”(第" & i & "行)的所有人为“" & rstemp("YYRXM") _
                                    & "”，这与您在导入名单中录入的姓名“" & .Cells(i, intNameCol) _
                                    & "”不一致。" & vbCrLf & "如果您确认数据库中的姓名有误，" _
                                    & "单击“是”将把数据库中的名字“" & rstemp("YYRXM") & "”修改为“" _
                                    & .Cells(i, intNameCol) & "”，单击“否”将取消本次操作！", _
                                    vbQuestion + vbYesNo + vbDefaultButton2, "提示")
                            If lngMsgBoxRet = vbNo Then
                                '不修改数据库，说明可能是录入有误
                                blnCheck = False
                                GoTo ExitLab
                            Else
                                '修改数据库中的名字
                                strSQL = "update SET_GRXX set" _
                                        & " YYRXM='" & Trim(.Cells(i, intNameCol)) & "'" _
                                        & " where YYRSFZH='" & Trim(.Cells(i, intSFZHCol)) & "'"
                                GCon.Execute strSQL
                            End If
                        End If
                    End If
                End If
            End If
            
            '第三步，姓名不能为空
            If IsNull(.Cells(i, intNameCol)) Or (Trim(.Cells(i, intNameCol)) = "") Then
                MsgBox "姓名不能为空。请输入第 " & i & " 行的姓名！", vbInformation, "提示"
                blnCheck = False
                GoTo ExitLab
            End If
            
            '第四步，校验性别
            If IsNull(.Cells(i, intSexCol)) Then
                '没有输入性别
                MsgBox "请输入 " & .Cells(i, intNameCol) & "(第 " & i & " 行) 的性别!", vbInformation, "提示"
                blnCheck = False
                GoTo ExitLab
            Else
                '内容是否合理
                If (Trim(.Cells(i, intSexCol)) <> "男") And (Trim(.Cells(i, intSexCol)) <> "女") Then
                    MsgBox .Cells(i, intNameCol) & "(第 " & i & " 行) 的性别输入有误！请检查。", vbInformation, "提示"
                    blnCheck = False
                    GoTo ExitLab
                End If
            End If
            
            '生日是否合理
            If Trim(.Cells(i, intBirthdayCol)) <> "" And Not IsNull(.Cells(i, intBirthdayCol)) Then
                If Not IsDate(Trim(.Cells(i, intBirthdayCol))) Then
                    MsgBox .Cells(i, intNameCol) & "(第 " & i & " 行) 的生日输入有误！请检查。", vbInformation, "提示"
                    blnCheck = False
                    GoTo ExitLab
                End If
            End If
            
            '第五步，姓名是否已经存在
            strSQL = "select Count(*) from SET_GRXX" _
                    & " where YYID='" & inYYID & "'" _
                    & " and YYRXM='" & Trim(.Cells(i, intNameCol)) & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rstemp(0) >= 1 Then
                strDuplicatePersons = strDuplicatePersons & Trim(.Cells(i, intNameCol)) & "，"
            End If
            rstemp.Close
        Next i
        
        '第六步，判断重复名单是否存在
        If strDuplicatePersons <> "" Then
            '截掉最后的逗号
            strDuplicatePersons = Left(strDuplicatePersons, Len(strDuplicatePersons) - 1)
            If MsgBox("在当前团体已经保存的预约名单中找到如下重复名单：" & vbCrLf & strDuplicatePersons _
                    & vbCrLf & vbCrLf & "这可能是因为重名，也可能是您选择了一个已经导入过的文件。" _
                    & vbCrLf & "单击“是”将把这些名单作为重名处理，单击“否”将放弃本次导入！" & vbCrLf _
                    & "要作为重名处理吗？", vbExclamation + vbYesNo + vbDefaultButton2, "小心") = vbNo Then
                blnCheck = False
                GoTo ExitLab
            End If
        End If
        If Not blnCheck Then GoTo ExitLab '校验是否通过（该语句可以不要）
        
        '***********************************************************************
        '                          校验完毕，写入数据库
        '***********************************************************************
        '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
        '                               开始事务
        '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
        GCon.BeginTrans
        '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
        On Error GoTo RollBack
        
        '如果文件有效，则开始导入该文件中的数据
        For i = 2 To .UsedRange.Rows.Count  'ObjSheet.UsedRange.Rows.Count是当前表的行数
            '只处理有姓名的行
            If Not IsNull(Trim(.Cells(i, intNameCol))) And Trim(.Cells(i, intNameCol)) <> "" Then
                strSQL = "" '初始化
                blnNewPerson = True
                strSelfBH = ""
                '是否存在卡号
                If Trim(.Cells(i, intICKNumCol)) <> "" _
                        And Not IsNull(Trim(.Cells(i, intICKNumCol))) Then
                    '************************************************************************
                    '                               存在会员卡号
                    '************************************************************************
                    '记录自定义档案号
                    strSelfBH = Trim(.Cells(i, intICKNumCol))
                    
                    Set rstemp = New ADODB.Recordset
                    strSQL = "select * from SET_ICKGL_Index" _
                            & " where ICKNum='" & strSelfBH & "'"
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    If rstemp.RecordCount > 0 Then      '说明该卡已发出,开始新建一个预约
                        '保存该人的HealthID
                        strTmpHealthID = rstemp("HealthID")
                        rstemp.Close
                        '根据预约的体检日期生成该日体检序号
                        intTJXH = GetMaxSN(inTJRQ, NOTAFFIRM_TABLE)
                        '生成一个GUID
                        lngGUID = GetGUID()
                        
                        blnNewPerson = False
                    Else '该卡未被发出,则需要新建一个HealthID，然后新建一个预约,并给新建的HealthID发卡
                        '▲▲▲这应当是手工输入自定义档案号的情况▲▲▲
                        '新建一个HealthID
                        strTmpHealthID = GetMaxHealthID(inTJRQ, NOTAFFIRM_TABLE)
                        '根据预约的体检日期生成该日体检序号
                        intTJXH = CInt(Right(strTmpHealthID, 4))
                        '生成一个GUID
                        lngGUID = GetGUID()
                    End If
                    
                ElseIf Not IsNull(.Cells(i, intSFZHCol)) And Trim(.Cells(i, intSFZHCol)) <> "" Then
                    '************************************************************************
                    '                               存在身份证号
                    '************************************************************************
                    strSQL = "select HealthID,SelfBH from SET_GRXX" _
                            & " where YYRSFZH='" & Trim(.Cells(i, intSFZHCol)) & "'"
                    Set rstemp = New ADODB.Recordset
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    If Not rstemp.EOF Then
                        '已经存在，是复检
                        strTmpHealthID = rstemp("HealthID")
                        strSelfBH = rstemp("SelfBH") & ""
                        rstemp.Close
                        '根据预约的体检日期生成该日体检序号
                        intTJXH = GetMaxSN(inTJRQ, NOTAFFIRM_TABLE)
                        '生成一个GUID
                        lngGUID = GetGUID()
                        
                        blnNewPerson = False
                    Else
                        '新到者
                        strTmpHealthID = GetMaxHealthID(inTJRQ, NOTAFFIRM_TABLE)
                        '根据预约的体检日期生成该日体检序号
                        intTJXH = CInt(Right(strTmpHealthID, 4))
                        '生成一个GUID
                        lngGUID = GetGUID()
                    End If
                    
                Else
                    '************************************************************************
                    '                          不存在会员卡号和身份证号
                    '************************************************************************
                    '新建一个HealthID
                    strTmpHealthID = GetMaxHealthID(inTJRQ, NOTAFFIRM_TABLE)
                    '根据预约的体检日期生成该日体检序号
                    intTJXH = CInt(Right(strTmpHealthID, 4))
                    '生成一个GUID
                    lngGUID = GetGUID()
                End If
                
                '是否需要生成自定义编号
                If strSelfBH = "" Then
                    strSelfBH = GetMaxSelfID()
                End If
                
                '判断分组编号列所填的值是否正确,必须为数字
                If Trim(.Cells(i, intFZBHCol)) <> "" _
                        And Len(Trim(.Cells(i, intFZBHCol))) <= 3 Then
                    If CheckFZIDValue(inYYID, Trim(.Cells(i, intFZBHCol))) = True Then
                        '第一种情况，Excel表有分组编号时，进入指定的分组
                        strSQL = "insert into FZ_FZSJ(YYID,GUID,FZID,SFTJ) values('" _
                                & inYYID & "'" _
                                & "," & lngGUID _
                                & "," _
                                & CInt(Val(.Cells(i, intFZBHCol))) & ",0)"
                            
                        tmpFZID = CInt(Val(.Cells(i, intFZBHCol)))
                    Else
                        '第二种情况，分组编号不存在时，进入当前分组
                        strSQL = "insert into FZ_FZSJ(YYID,GUID,FZID,SFTJ) values('" _
                               & inYYID & "'" _
                               & "," & lngGUID _
                               & "," & intFZID & ",0)"
                        tmpFZID = intFZID
                    End If
                Else
                    '第三种情况，没有指定分组时，进入当前分组
                    strSQL = "insert into FZ_FZSJ(YYID,GUID,FZID,SFTJ) values('" _
                           & inYYID & "'" _
                           & "," & lngGUID _
                           & "," & intFZID & ",0)"
                    tmpFZID = intFZID
                End If
                '写入数据库
                GCon.Execute strSQL
                
                '将该人所在分组的项目进入YY_SJDJDX表
                strSQL = "select * from YY_TJDJDX where YYID='" & inYYID & "'" _
                        & " and FZID=" & tmpFZID
                Set rstemp = New ADODB.Recordset
                rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                If rstemp.RecordCount > 0 Then
                    '首先清除该人所选的项目
                    strSQL = "delete from YY_SJDJDX where GUID='" & lngGUID & "'"
                    GCon.Execute strSQL
                    
                    '将该人所选分组的项目填入YY_SJDJDX
                    rstemp.MoveFirst