modcommon.bas

VB6.0编写的医院影像系统

    
    '------------------------------
    '改变指定文件的路径,并返回结果
    '------------------------------
    
    Dim strTemp As String
    
    '先获得干净的文件名
    strTemp = GetFileName(strFile)
    
    '去除strPathToSet的后缀
    ChangeFilePath = TrimDir(strPathToSet) & "\" & strTemp
    
End Function

Public Function FileSize(strFile As String)
    
    '------------------------------
    '返回文件的大小
    '------------------------------
    
    Dim cFile As File
    
    Set cFile = FSO.GetFile(strFile)
    FileSize = cFile.Size
    
    Set cFile = Nothing
    
End Function

Public Function DeleteFile(strFile As String) As Boolean
    
    '--------------------------------
    '删除制定的文件，并不返回错误
    '--------------------------------
    
    On Error GoTo ErrHandle
    
    FSO.DeleteFile strFile
    DeleteFile = True
    Exit Function

ErrHandle:
    DeleteFile = False
    
End Function


Public Function EnPassWord(strConn As String) As String
    
    '---------------------------------
    '翻译Jet的OLEDB连接的PassWord
    '---------------------------------
    Dim strTemp As String
    
    strTemp = strConn
    If InStr(1, strConn, "Microsoft.Jet.OLEDB") > 0 Then
        If InStr(1, strConn, "Jet OLEDB:Database Password=rich") = 0 Then
            If Right(strTemp, 1) <> ";" Then
                strTemp = strTemp & ";"
            End If
            strTemp = strTemp & "Jet OLEDB:Database Password=rich"
        End If
    End If
    
    EnPassWord = strTemp
    
End Function

Public Function GetMaxID(ByVal strTable As String, ByVal strFld As String, Optional strConn As String = "System") As Long
    
    '------------------------------------
    '返回最大的可用序号
    '------------------------------------
    
    Dim rsTemp As ADODB.Recordset
    Dim strSQL As String
    
    strSQL = "SELECT MAX(" & strFld & ") AS MAXID FROM " & strTable
    
    Set rsTemp = OpenRS(strSQL, strConn)
    
    GetMaxID = Val(rsTemp!MAXID & vbNullString) + 1
    
End Function

Public Function ShowEditConflictError()
    
    '-----------------------------------
    '显示由于其它用户编辑而造成的错误
    '-----------------------------------

    MsgBox "由于其它用户预先编辑了您此次提交的记录，因而不能更新。", vbOKOnly + vbExclamation, "数据冲突"
    
End Function

Public Function MakeSQLConnectionString(strServer As String, UserID As String, Optional PassWord As String = vbNullString, Optional IniCatalog As String = vbNullString) As String
    
    '---------------------------
    '根据传递过来的参数形成SQL连接字串
    '---------------------------
    
    Dim strTemp As String
    
    strTemp = "Provider=SQLOLEDB.1;Persist Security Info=False"
    
    strTemp = strTemp & ";User ID=" & UserID
    
    If PassWord <> vbNullString Then
        strTemp = strTemp & ";Password=" & PassWord
    End If
    
    If IniCatalog <> vbNullString Then
        strTemp = strTemp & ";Initial Catalog=" & IniCatalog
    End If
    
    If strServer <> vbNullString Then
        strTemp = strTemp & ";Data Source=" & strServer
    End If
    
    MakeSQLConnectionString = strTemp
    
End Function

Public Function MakeSQLDateString(cD As Date)
    
    '--------------------------------
    '根据SQL的不同返回不同的日期描述
    '--------------------------------
    
    MakeSQLDateString = gstrDateQuote & Year(cD) & "-" & Month(cD) & "-" & Day(cD) & gstrDateQuote
    
End Function

Public Function MakeDate(ByVal Year As Long, ByVal Month As Long, ByVal Day As Long) As Date

    '-----------------------------
    '根据传递过来的三个参数返回日期
    '-----------------------------
    If Month > 12 Then      '如果大于12, 则在年上进位
        Year = Year + (Month - 1) \ 12
        Month = Month Mod 12
        If Month = 0 Then Month = 12
    End If
    
    MakeDate = CDate(Year & "-" & Month & "-" & Day)
    
End Function

Public Function MakePath(strPath As String) As String
    
    '---------------------------
    '将路径字符串转换为结尾为“\”的字符串
    '---------------------------
    
    MakePath = Trim(strPath)
    strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
    
End Function

Public Function PopOrganTemp(OrganName As String)

    
    '------------------------------------
    '弹出对应该器官组合的模板窗体
    '------------------------------------
    
    Dim strSQL As String
    Dim strTempName As String
    Dim strTempList() As String
    Dim strCombList() As String
    Dim rsTemp As ADODB.Recordset
    Dim i As Integer
    Dim j As Integer

    If Not frmOrganTemp.Loaded Then
        strSQL = "SELECT COMB_NAME, COMB_STRING, TEMP_NAME FROM US_ORGAN_COMB WHERE COMB_NAME = '" & OrganName & "'"
        Set rsTemp = OpenRS(strSQL)
        
        If rsTemp.EOF Then
            '警告没有对应的模板
            MsgBox "抱歉, 未发现相对应的模板, 请直接在 [图象描述] 和 [超声提示] 中输入检查结果! ", vbOKOnly + vbInformation, "提示"
            Exit Function
            
        End If
        strTempList() = Split(rsTemp!TEMP_NAME, US_STR_TEMPSPLIT)
        strCombList() = Split(rsTemp!COMB_STRING, US_STR_TEMPSPLIT)
    Else
        strTempList() = Split(TEMP_STRING, US_STR_TEMPSPLIT)
        strCombList() = Split(ORGAN_STRING, US_STR_TEMPSPLIT)
    End If
        
    '依次弹出器官模板
    LastTempNumber = UBound(strTempList())
    For i = 0 To UBound(strTempList())
        
        strTempName = strTempList(i)
        gstrCombString = strCombList(i)
        modCommon.TempOrderNumber = i
        If i > 0 Then j = i - 1 Else j = i
        
        Screen.MousePointer = vbHourglass
        
        '根据模板的名称决定弹出的窗体名
        Select Case strTempName
        
            Case "肝胆胰脾后腹膜"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempL_GB_P_S_BP.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "眼睛"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempEyes.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "透环"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempRing.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "双肾双肾上腺"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempK_A.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "双肾穿刺定位"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempKidneysPuncture.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "乳腺探测"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempMammaryGland.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "甲状腺"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempThyroidGland.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "椎动脉"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempArteriaVertebralis.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "子宫附件"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempWombAdnexa.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "产科"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempFoetus.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "胸腔探测"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempThorax.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "移植肾"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempKidneysTransplant.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "下肢静脉"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempLowerLimbVein.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "阴囊"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempScrotum.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "心脏"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
'                       frmTempHeartValue.Show vbModal
'                       frmTempHeartDescribe.Show vbModal
                    frmTempHeart.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "下肢动脉"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempLowerLimbArtery.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "颈动脉"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempNeckArtery.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "双肾输尿管膀胱前列腺"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempK_U_B_P.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "卵泡检测"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempOvary.txtODiagDay.Text = Date
                    frmTempOvary.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "肿块"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempTumour.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "腮腺"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempParotid.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "肝穿刺"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempLiverPuncture.Show , frmMain 'vbModal
                    Exit For
                End If
                
            Case "胃"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempStomach.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "颌下腺"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempJaw.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "半月板"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempMeniscus.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "阑尾"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempAppendix.Show , frmMain ' vbModal
                    Exit For
                End If
            
            Case "经颅"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempBySkull.Show , frmMain ' vbModal
                    Exit For
                End If
                
            Case "胸腔心包腹腔"
                If (i = 0 And Not OldTempLoadFlag(i)) Or (i > 0 And Not TempLoadFlag(j) And Not OldTempLoadFlag(i)) Then
                    frmTempChest_HeartP_Abdomen.Show , frmMain 'vbModal
                    Exit For
                End If
                
            Case Else
                Screen.MousePointer = vbNormal
                MsgBox "抱歉, 未发现相对应的模板, 请直接在 [图象描述] 和 [超声提示] 中输入检查结果! ", vbOKOnly + vbInformation, "提示"
                
        End Select
    Next i

End Function

'取得相应表的最大值
Public Function GetSerialID(ByVal sTableName As String) As Long
Dim sSQL As String
Dim rsTemp As Recordset
Dim lSerialID As Long
Dim lTempID As Long

    sSQL = "select SerialID from us_autonumber where tablename='" & sTableName & "'"
    Set rsTemp = GDB.Execute(sSQL)
    
    With rsTemp
    Do While Not .EOF
        lSerialID = rsTemp!serialid
        .MoveNext
    Loop
    End With
    
        
    lTempID = lSerialID + 1
    
    sSQL = "update us_autonumber set serialid=" & lTempID & " where tablename='" & sTableName & "'"
    GDB.Execute sSQL
    
    GetSerialID = lTempID
    
    rsTemp.Close
    Set rsTemp = Nothing
    
End Function