frmfilmlookup.frm

1、以DLL形式提供医生工作站 2、 根据【检查项目】

         Left            =   2040
         TabIndex        =   3
         Top             =   120
         Width           =   1695
      End
      Begin VB.Label lblPatientSex 
         BackStyle       =   0  'Transparent
         Caption         =   "性别:"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00FFFFFF&
         Height          =   375
         Left            =   3840
         TabIndex        =   2
         Top             =   120
         Width           =   975
      End
      Begin VB.Label lblAge 
         BackStyle       =   0  'Transparent
         Caption         =   "年龄:"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00FFFFFF&
         Height          =   375
         Left            =   5160
         TabIndex        =   1
         Top             =   120
         Width           =   1095
      End
   End
End
Attribute VB_Name = "frmFilmLookUp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const PhotoCount = 12

'图片路径数组
Dim filmPaths(PhotoCount)

Dim nPictureCount As Long
Dim DownLoadPaths() As String
Public CurCheckNumber As String

Private Sub Form_Resize()
On Error GoTo ErrHandler

    
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub


Private Sub Form_Activate()
On Error GoTo ErrHandler
        Me.BackColor = mHLSRGB.COLORSET
        Call InitFilmParts
        If Not InitPhotoFromFile Then
            Call InitPhotoFromDB
        End If
        
        Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub
Private Sub Form_Unload(cancel As Integer)
    Dim i As Long
    For i = 0 To dcmToPrint.Count - 1
        dcmToPrint(i).FreeMemory
    Next
End Sub

Private Sub Form_Load()
     
    Dim i As Integer
    For i = 0 To PhotoCount - 1
        dcmToPrint(i).LicenseCode = "000510006000051000560005300053"
        dcmToPrint(i).OCXLanguage = 0
        dcmToPrint(i).ImageZoomBestFit = True
        dcmToPrint(i).ImageTool = 14
        dcmToPrint(i).ImageZoomBestFit = True
        If Not dcmToPrint(i).LicenseIsOK Then
            MsgBox "程序出错, 请与系统管理员联系!", vbInformation
            End
        End If
    Next
        
        
    myConn.CursorLocation = adUseClient
    If myConn.State = adStateClosed Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    

End Sub


'初始化投照部位图片
Private Function InitFilmParts() As Boolean
On Error GoTo ErrHandler
    
'    nSelectPhotoIndex = -1
    
    If CurCheckNumber = "" Then
        MsgBox "检查编号不正确!", vbExclamation, "提示"
        Unload Me
    End If
    
    '初始化病人信息
    Dim strSql As String
    'strSql = "select PatientName, PatientSex , to_char(PatientAge) ||  AgeWeigh  as Age, " _
    '    + " CheckDate " _
    '    + " FROM Patient,CheckList " _
    '    + " WHERE Patient.CheckNumber = checklist.checknumber and Patient.CheckNumber = '" _
    '    + CurCheckNumber + "'"
    
    'strSql = "select PatientName, PatientSex , to_char(PatientAge) ||  AgeWeigh  as Age, " _
    '    + " CheckDate " _
    '    + " FROM Patient,CheckList " _
    '    + " WHERE Patient.CheckNumber = checklist.checknumber and Patient.CheckNumber = '" _
    '    + CurCheckNumber + "'"
    
    strSql = "SELECT  PATIENT_ID AS 编号, PATIENT_NAME AS 姓名,PATIENT_SEX AS 性别,to_char(PATIENT_AGE) || AGE_WEIGHT as 年龄," _
    + " CHECK_DATE AS 检查日期  FROM CHECK_LIST WHERE PATIENT_ID = '" _
        + CurCheckNumber + "'"
        
    Dim rsPatient As New ADODB.Recordset
    If rsPatient.State = adStateOpen Then
        rsPatient.Close
    End If
    If myConn.State = adStateClosed Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsPatient.Open strSql, myConn
    If rsPatient.EOF Or rsPatient.BOF Then
        MsgBox "获取病人信息出错, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Function
    End If
    
    Dim strPhotoDate As String
    lblCheckNumber.Caption = "编号:" + CurCheckNumber
    If Not IsNull(rsPatient.Fields("姓名")) Then
        lblPatientName.Caption = "姓名:" + rsPatient.Fields("姓名")
    Else
        lblPatientName.Caption = "姓名:未知"
    End If
    
    If Not IsNull(rsPatient.Fields("性别")) Then
        lblPatientSex.Caption = "性别:" + rsPatient.Fields("性别")
    Else
        lblPatientSex.Caption = "性别:未知"
    End If
    If Not IsNull(rsPatient.Fields("年龄")) Then
        lblAge.Caption = "年龄:" + rsPatient.Fields("年龄")
    Else
        lblAge.Caption = "年龄:未知"
    End If
    If Not IsNull(rsPatient.Fields("检查日期")) Then
        strPhotoDate = "日期:" & rsPatient.Fields("检查日期").Value
    Else
        strPhotoDate = "日期:" + CStr(Now)
    End If
    
    rsPatient.Close
    
    Set rsPatient = Nothing
    
    strSql = " SELECT id, Photo_Path from CHECK_PART where rownum <= 12 and PATIENT_ID = '" _
    + CurCheckNumber + "' AND REGISTER_DATE ='" + frmCheckList.CurPatient_Reg_Date + "'"
    
    Dim rsPhotoPath As New ADODB.Recordset
    rsPhotoPath.Open strSql, myConn
    
    'Dim nPictureCount As Long
    nPictureCount = rsPhotoPath.RecordCount
    
    If rsPhotoPath.RecordCount <= 0 Then
        MsgBox "该病人还没有拍照!", vbExclamation, "提示"
        Unload Me
    End If
    
    Dim i As Integer
    i = 0
    While Not rsPhotoPath.EOF And Not rsPhotoPath.BOF
        If Not IsNull(rsPhotoPath.Fields("Photo_Path")) Then
            filmPaths(i) = getAbsolutePath(rsPhotoPath.Fields("Photo_Path"))
        End If
        rsPhotoPath.MoveNext
        i = i + 1
        
    Wend
    rsPhotoPath.Close
    Set rsPhotoPath = Nothing

    
    Exit Function
ErrHandler:
    MsgBox "患者图片加载失败, 原因:" + Err.Description, vbExclamation, "警告"
End Function

'从数据库读取图片
Private Function InitPhotoFromDB() As Boolean
On Error GoTo ErrHandler
    
    Dim strSql As String
    strSql = " SELECT id, Photo_Path from CHECK_PART where rownum <=12 and PATIENT_ID = '" _
        + frmRecordEdit.CURRENT_REPORT_CHECKNUMBER + "'" _
        + " AND REGISTER_DATE = '" + frmCheckList.CurPatient_Reg_Date + "'"
    
    Dim rsPhotoPath As New ADODB.Recordset
    If myConn.State = adStateClosed Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsPhotoPath.Open strSql, myConn
    
    Dim lWidth, lHeight, lQuotient, w, h As Long
    Dim i As Integer
    ReDim DownLoadPaths(nPictureCount) As String
    i = 0
    For i = 0 To rsPhotoPath.RecordCount - 1
        Dim id As Long
            If Not IsNull(rsPhotoPath.Fields("id")) Then
                id = rsPhotoPath.Fields("id")
            End If
        
        Dim strSrc As String
        strSrc = App.Path + "\download" + "\" + CStr(i) + ".dcm"
        'strSrc = App.Path + "\download" + "\2" + ".dcm"
        DownLoadPaths(i) = strSrc
        If Dir(DownLoadPaths(i), vbArchive Or vbSystem Or vbReadOnly Or vbHidden) <> "" Then
            Kill DownLoadPaths(i)
        End If
        
        If Not IsNull(rsPhotoPath.Fields("ID")) Then
            Call DatabasePicToFile("CHEKC_PART", "Image", "WHERE ID = '" + CStr(id) + "'", strSrc)
        End If
        '=================
        rsPhotoPath.MoveNext
    Next
    
    
    rsPhotoPath.Close
    Set rsPhotoPath = Nothing

    
    'initPhotoFromDB = False
    For i = 0 To nPictureCount - 1
        If DownLoadPaths(i) <> "" Then
            If Dir(DownLoadPaths(i), vbArchive Or vbHidden Or vbReadOnly Or vbSystem Or vbNormal) = "" Then
                'MsgBox "该患者胶片路径:" + DownLoadPaths(i) + "有误, 请与系统管理员联系!", vbExclamation, "提示"
                MsgBox "请您确定该患者胶片正确读取!", vbExclamation, "提示"
                InitPhotoFromDB = False
            Else
                If dcmToPrint(i).OpenFile(DownLoadPaths(i)) = False Then
                    Exit For
                End If
            End If
            Pause 500
        End If
    
    Next
    
    Call InitSize
    InitPhotoFromDB = True
    Exit Function
ErrHandler:
    InitPhotoFromDB = False
    MsgBox "患者图片加载失败, 原因:" + Err.Description, vbExclamation, "警告"
    
End Function



'从文件读取图片
Private Function InitPhotoFromFile()
On Error GoTo ErrHandler
    Dim lWidth, lHeight, lQuotient, w, h As Long
    Dim i As Integer
    InitPhotoFromFile = False
    For i = 0 To nPictureCount - 1
        If filmPaths(i) <> "" Then
            If Dir(filmPaths(i), vbArchive Or vbHidden Or vbReadOnly Or vbSystem Or vbNormal) = "" Then
                MsgBox "该患者胶片路径:" + filmPaths(i) + "有误, 请与系统管理员联系!", vbExclamation, "提示"
                InitPhotoFromFile = False
            Else
                If dcmToPrint(i).OpenFile(filmPaths(i)) = False Then
                    Exit For
                End If
            End If
            Pause 500
        End If
    Next
    
    Call InitSize
    InitPhotoFromFile = True
    Exit Function
ErrHandler:
    MsgBox "患者图片加载失败, 原因:" + Err.Description, vbExclamation, "警告"
End Function
Private Function InitSize()
On Error GoTo ErrHandler
    Dim i As Long
    If nPictureCount = 0 Then
        
    ElseIf nPictureCount > 0 And nPictureCount <= 6 Then
        For i = 0 To nPictureCount - 1
            dcmToPrint(i).Width = frmPatientInfo.Width / 2 - 200
            dcmToPrint(i).Height = frmPatientInfo.Height / 3 - lblCheckNumber.Height
            dcmToPrint(i).Left = dcmToPrint(0).Left + dcmToPrint(0).Width * (i Mod 2)
            dcmToPrint(i).Top = dcmToPrint(0).Top + dcmToPrint(0).Height * (i \ 2)
            dcmToPrint(i).Visible = True
        Next
    ElseIf nPictureCount > 6 And nPictureCount < PhotoCount Then
        For i = 0 To nPictureCount - 1
            dcmToPrint(i).Visible = True
        Next
    Else
        MsgBox "图片张数不符合查看要求", vbExclamation, "提示"
    End If
    
    Exit Function
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Function