modcommon.bas

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

        .cboHospital.Text = rsRPT!SEND_HOSPITAL & vbNullString
        .cboSSection.Text = rsRPT!SEND_SECTION & vbNullString
        .cboSDoctor.Text = rsRPT!SEND_DOCTOR & vbNullString
        .txtREC_NO.Text = rsRPT!REC_NO & vbNullString
        .cboImageQuality.Text = rsRPT!IMAGE_QUALITY & vbNullString
        .txtSickAge.Text = rsRPT!Sick_Age & vbNullString
        .cboAgeUnit.Text = rsRPT!AGE_UNIT & vbNullString
        .txtUnit.Text = rsRPT!SICK_UNIT & vbNullString
        .txtFamily.Text = rsRPT!SICK_FAMILY & vbNullString
        .txtSickBirth.Value = rsRPT!SICK_BIRTH & vbNullString
        .cboSickClass.Text = rsRPT!SICK_CLASS & vbNullString
        .txtSickName.Text = rsRPT!SICK_NAME & vbNullString
        .cboSickSex.Text = rsRPT!SICK_SEX & vbNullString
        .cboINS_FRE.Text = rsRPT!INSTER_FREQUEN & vbNullString
        .txtSickBirth.Value = rsRPT!SICK_BIRTH & vbNullString
        USNO = rsRPT!US_NO & vbNullString
        Select Case .cboOrganName.Text
            Case "心脏"
                .txtDescribe.Text = rsRPT!VALUE1 & vbNullString & rsRPT!DESCRIBE & vbNullString
            Case Else
                .txtDescribe.Text = rsRPT!DESCRIBE & vbNullString
        End Select
        
        .txtUSTip(0).Text = rsRPT!US_TIP1 & vbNullString
        .txtUSTip(1).Text = rsRPT!US_TIP2 & vbNullString
        .txtUSTip(2).Text = rsRPT!US_TIP3 & vbNullString
        .txtUSTip(3).Text = rsRPT!US_TIP4 & vbNullString
        .txtUSTip(4).Text = rsRPT!US_TIP5 & vbNullString
        .txtUSTip(5).Text = rsRPT!US_TIP6 & vbNullString
        .txtUSTip(6).Text = rsRPT!US_TIP7 & vbNullString
        .txtUSTip(7).Text = rsRPT!US_TIP8 & vbNullString
        
    '        If .txtSickNo.Text = "" Then .txtSickBirth.Value = Account_BirthDay(.txtSickAge.Text, .cboAgeUnit.Text)
        
    End With
    
    '当此报告无动态视频时报告视频按钮不可用
    strSQL = "SELECT * FROM US_MEDIA WHERE FILE_TYPE = 'VIDEO' AND US_NO = '" & frmReport.txtUSNo & "'"
    Set rsRPT = OpenRS(strSQL, "Data")
    If rsRPT.RecordCount > 0 Then
        frmMain.atBarMain.Tools("ID_USViewVideo").Enabled = True
    Else
        frmMain.atBarMain.Tools("ID_USViewVideo").Enabled = False
    End If
    
End Function

Public Sub CenterForm(frm As Form)
    
    '-------------------
    '将一个Form移动
    '到屏幕的中央
    '-------------------
    
    frm.Move (Screen.width - frm.width) / 2, (Screen.height - frm.height) / 2
    If frm.Left < 0 Then frm.Left = 0
    If frm.Top < 0 Then frm.Top = 0
    
End Sub

Public Sub MaxForm(frm As Form)

    '---------------------
    '将一个Form的位置充满屏幕
    '---------------------
    
    frm.Move 0, 0, Screen.width, Screen.height
    
End Sub

Public Function SetDate(DateString As String) As String
    
    '---------------------
    '将一个字符串转换为合法的日期类型
    '---------------------
    
    Dim cTR As New TextReplace
    
    cTR.Text = DateString
    cTR.Replace ".", "-", False
    SetDate = cTR.Text
    
    Set cTR = Nothing
    
End Function

Public Function ImageFileToSoundFile(strSoundFileName As String) As String
    
    '----------------------------
    '将一个图象文件名获得对应的声音文件名
    '即文件主名+WAV，含路径
    '----------------------------
    
    '这里要求后缀为3
    ImageFileToSoundFile = Left(strSoundFileName, Len(strSoundFileName) - 3) & "WAV"
    
End Function

Public Function ShowReportImage()
    
    '---------------------
    '显示报告对应的图片
    '---------------------
    
    '如果是"全部显示,则退出程序"
    If frmImageResult.Loaded = False Then Exit Function
    If frmImageResult.chkShowAll.Value = 1 Then Exit Function
    
    On Error GoTo ErrHandle
    
    Dim rsTemp As ADODB.Recordset
    Dim strFile As String
    Dim cIF As ImageFile
    
    Set rsTemp = OpenRS("SELECT * FROM US_MEDIA WHERE US_NO = '" & rsUS_ReportSick!US_NO & "' AND FILE_TYPE = 'IMAGE'", "Data")
    frmImageResult.IB.Clear
    If rsTemp.RecordCount > 0 Then
        Do While Not rsTemp.EOF
            strFile = rsTemp!FILE_NAME
            
            '在这里，对于从网络读取图象(即网络共享版本)或者从指定的目录读取图象(从备份中读取)时，
            '可以改变文件名的路径
            If Not FSO.FileExists(strFile) Then
'                strFile = ChangeFilePath(strFile, gstrImageDir)
                strFile = FindMediaFile(strFile, True, True)
            End If
            
            Set cIF = frmImageResult.IB.ImageFiles.Add(strFile)
            '如果加入cIF成功则可以进一步查找声音和是否打印的标志
            If Not cIF Is Nothing Then
                cIF.TagSave = True
                If rsTemp!SOUND_FILE_NAME & vbNullString <> vbNullString Then
                    cIF.SoundFile = rsTemp!SOUND_FILE_NAME
                    cIF.TagSound = True
                End If
                If rsTemp!Print Then cIF.TagPrint = True
            End If
            rsTemp.MoveNext
        Loop
        frmImageResult.IB.ShowImage
    End If
    
    Exit Function

ErrHandle:
    Exit Function
    
End Function

Public Function ShowAllReportImage()
    
    '----------------------
    '显示所有的报告图片
    '----------------------
    Dim rsReport As ADODB.Recordset
    Dim rsTemp As ADODB.Recordset
    Dim strFile As String
    Dim cIF As ImageFile
    
    frmImageResult.IB.Clear
    
    '为了避免在deUS的记录集移动时造成的图像闪烁,复制一个该记录集的克隆,但
    '注意要同时复制该记录集的Filter属性,否则记录数会不符
    Set rsReport = rsUS_ReportSick.Clone
    rsReport.Filter = rsUS_ReportSick.Filter
    
    With rsReport
        If .RecordCount = 0 Then Exit Function
        .MoveFirst
        frmImageResult.IB.Clear
        Do While Not .EOF
            Set rsTemp = OpenRS("SELECT * FROM US_MEDIA WHERE US_NO = '" & !US_NO & "' AND FILE_TYPE = 'IMAGE'", "Data")
            If rsTemp.RecordCount > 0 Then
                Do While Not rsTemp.EOF
                    strFile = rsTemp!FILE_NAME
                    Set cIF = frmImageResult.IB.ImageFiles.Add(strFile)
                    '如果加入cIF成功则可以进一步查找声音和是否打印的标志
                    If Not cIF Is Nothing Then
                        cIF.TagSave = True
                        If rsTemp!SOUND_FILE_NAME & vbNullString <> vbNullString Then
                            cIF.SoundFile = rsTemp!SOUND_FILE_NAME
                            cIF.TagSound = True
                        End If
                        If rsTemp!Print Then cIF.TagPrint = True
                    End If
                    rsTemp.MoveNext
                Loop
            End If
            .MoveNext
        Loop
        frmImageResult.IB.ShowImage
    End With
    
    '释放对象
    Set rsReport = Nothing
    Set rsTemp = Nothing
    
End Function

Public Function FindMediaFile(ByVal strFile As String, Optional bSearchNet As Boolean = False, Optional bSearchBackup As Boolean = False) As String

    '---------------------------------------
    '查询记录中文件的实际位置
    '查询的次序是:
    '1. 首先查询本文件是否存在(针对是文件名是全路径的情况);
    '2. 其次查询本机的媒体目录+文件名后的文件是否存在;
    '3. 其次查询网络媒体上传的路径+文件名后的文件是否存在;(可选)
    '4. 其次查询备份目录+文件名后的文件是否存在(可选);
    '以上若有一步得到了文件的存在,则返回此文件;否则返回一个Null字符串
    '
    '这样的处理对于图像的显示基本满足要求,但在查询结果中插入已存在文件后,保存时可能引起混淆
    '到时再对此情况加以处理
    '---------------------------------------
    
    Dim strFileName As String
    Dim strTemp As String
    
    strFileName = FSO.GetFileName(strFile)
    FindMediaFile = vbNullString
    
    'Setp1
    strTemp = strFile
    If FSO.FileExists(strTemp) Then
        FindMediaFile = strTemp
        Exit Function
    End If
         
    'Step2
    strTemp = MakePath(gstrImageDir) & strFileName
    If FSO.FileExists(strTemp) Then
        FindMediaFile = strTemp
        Exit Function
    End If
    
    'Step3
    If bSearchNet Then
        strTemp = MakePath(gstrServerImageDir) & strFileName
        If FSO.FileExists(strTemp) Then
            FindMediaFile = strTemp
            Exit Function
        End If
    End If
        
    'Step4
    If bSearchBackup Then
        strTemp = MakePath(gstrBackupDir) & strFileName
        If FSO.FileExists(strTemp) Then
            FindMediaFile = strTemp
            Exit Function
        End If
    End If

End Function

Public Sub PlaySound(strSoundFile As String)
    
    '------------
    '播放文件
    '------------
    Dim cMM As New Mmedia
    
    With cMM
        .Wait = True
        .mmOpen strSoundFile
        Screen.MousePointer = vbHourglass
        .mmPlay
        .mmClose
        Screen.MousePointer = vbNormal
    End With
    
End Sub

Public Sub PlaySoundAPI(strSoundFile As String)
    
    '--------------------------------
    '用API播放声音
    '--------------------------------
    
    sndPlaySound vbNullString, 0    '先停止当前声音的播放
    sndPlaySound DoubleQuote(strSoundFile), SND_ASYNC
    
End Sub

Public Function LenByte(str As String) As Integer
    
    '-------------------
    '测量字符串的字节数
    '-------------------
    
    Dim S1 As String
    
    S1 = StrConv(str, vbFromUnicode)
    LenByte = LenB(S1)
    
End Function

Public Function GetFirstString(str As String, strSplit As String) As String
    
    '-------------------------
    '获取以strSplit为分割的第一个字符串
    '-------------------------
    
    Dim i As Long
    
    i = InStr(1, str, strSplit)
    If i <> 0 Then
        GetFirstString = Left(str, i - 1)
    Else
        GetFirstString = vbNullString
    End If
    
End Function

Public Function GetLastString(str As String, strSplit As String, Optional IncludingSplit As Boolean = True) As String
    
    '-------------------------
    '获取以strSplit为分割的后一个字符串
    '-------------------------
    
    Dim i As Long
    
    i = InStr(1, str, strSplit)
    If i <> 0 Then
        If IncludingSplit Then
            GetLastString = Right(str, Len(str) - i + 1)
        Else
            GetLastString = Right(str, Len(str) - i + 1 - Len(strSplit))
        End If
    Else
        If IncludingSplit Then
            GetLastString = str
        Else
            GetLastString = vbNullString
        End If
    End If
    
End Function

Public Property Get AdminUser() As Boolean
    
    '-----------------------------
    '返回用户是否拥有管理员的权限
    '-----------------------------
    
    AdminUser = (UserType = "系统管理员" Or UserType = "超级管理员")
    
End Property

Public Function TrimDir(strDir) As String

    '---------------------------
    '去掉目录字符串最后的"\"字符
    '---------------------------
    
    If Right(strDir, 1) = "\" Then
        TrimDir = Left(strDir, Len(strDir) - 1)
    Else
        TrimDir = strDir
    End If
    
End Function

Public Function SingleQuote(str As String) As String
    
    '------------------------------
    '返回用单引号符包括的字符串
    '------------------------------
    SingleQuote = "'" & str & "'"

End Function

Public Function GetFilePath(strFullPathName As String) As String

    Dim i As Integer
    
    i = InStrRev(strFullPathName, "\")
    
    If i <> 0 Then GetFilePath = Left(strFullPathName, i)
    
End Function

Public Function DoubleQuote(str As String) As String
    
    '------------------------------
    '返回用双引号符包括的字符串
    '------------------------------
    DoubleQuote = """" & str & """"

End Function

Public Function GetFileName(strFullPathName As String) As String

    '-----------------------------
    '从完整文件路径中返回文件名
    '-----------------------------

    Dim i As Integer
    
    On Error GoTo ErrHandle

    i = InStrRev(strFullPathName, "\")
    If i <> 0 Then
        GetFileName = Mid(strFullPathName, i + 1)
        Exit Function
    End If
    
'    For i = Len(strFullPathName) To 1 Step -1
'        If Mid(strFullPathName, i, 1) = "\" Then
'            GetFileName = Mid(strFullPathName, i + 1)
'            Exit Function
'        End If
'    Next i
    
ErrHandle:
    GetFileName = strFullPathName
    
End Function

Public Function ChangeFilePath(strFile As String, strPathToSet As String) As String