frmphoto.frm

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

    MsgBox Err.Description, vbExclamation, "提示"
End Sub
'按钮事件--椭圆
Private Sub btnEllipse_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageTool = 7
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'按钮事件--浮雕
Private Sub btnEmboss_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageProcessEmboss = True
    dcmPhotoExamine.ImageTool = 1
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'按钮事件--放大镜
Private Sub btnEnlarge_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageMagnifyZoomSize = 2
    dcmPhotoExamine.ImageMagnifyProcess = 0
    dcmPhotoExamine.ImageTool = 3
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub
'按钮事件--滤镜
Private Sub btnFilterClean_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageTool = 3
    dcmPhotoExamine.ImageMagnifyProcess = 1
    dcmPhotoExamine.ImageMagnifyZoomSize = 1
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'按钮事件--左右
Private Sub btnLeftRight_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageProcessFlipHorzontal = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub
'按钮事件--长度
Private Sub btnLength_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageTool = 5
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'按钮事件--旋转
Private Sub btnNinety_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageProcessRotate = 90
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub
'按钮事件--信息
Private Sub btnPatientInfo_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageOverlayOn = Not dcmPhotoExamine.ImageOverlayOn
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

Private Sub btnPlay_Click()
    If tmrPlaySlice.Enabled = True Then
        btnPlay.Caption = "播放"
    Else
        btnPlay.Caption = "停止"
    End If
    tmrPlaySlice.Enabled = Not tmrPlaySlice.Enabled
End Sub

'按钮事件--降燥
Private Sub btnProcessBlur_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageProcessBlur = True
    dcmPhotoExamine.ImageTool = 1
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'按钮事件--滤波处理
Private Sub btnProcessFilter_Click()
On Error GoTo ErrHandler
    
    dcmPhotoExamine.ImageProcessFilter = True
    
    dcmPhotoExamine.ImageTool = 1
    
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub
'按钮事件--矩形
Private Sub btnRectangle_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageTool = 6
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'按钮事件--反色
Private Sub btnReverse_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageProcessInvert = True
    dcmPhotoExamine.ImageColorScheme = -dcmPhotoExamine.ImageColorScheme
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub
'按钮事件--标尺
Private Sub btnRuler_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageOverlayShowRuler = Not dcmPhotoExamine.ImageOverlayShowRuler
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'按钮事件--锐化
Private Sub btnSharpen_Click()
On Error GoTo ErrHandler
    bSharpen = Not bSharpen
    dcmPhotoExamine.ImageProcessSharpen = bSharpen
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub
'按钮事件--平滑
Private Sub btnSmooth_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageSmoothOn = True
    dcmPhotoExamine.ImageTool = 1
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub
'按钮事件--缩小
Private Sub btnSubScale_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageZoomPct = dcmPhotoExamine.ImageZoomPct - DICOM_ADD_SCALE
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'按钮事件--上下
Private Sub btnUpdown_Click()
On Error GoTo ErrHandler
    dcmPhotoExamine.ImageProcessFlipVertical = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub







Private Sub Form_Activate()
On Error GoTo ErrHandler
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub


Private Sub Form_Load()
On Error GoTo ErrHandler
    dcmPhotoExamine.left = 0
    dcmPhotoExamine.Top = 0
    dcmPhotoExamine.Width = Me.Width
    dcmPhotoExamine.Height = Me.Height - Me.picFilmEdit.Height
    
    DEFAULT_FILM_PATH = App.Path + "\NoImage.bmp"
    
    Call InitDcm(dcmPhotoExamine)
    If dcmPhotoExamine.LicenseIsOK = False Then
        MsgBox "程序错误, 重新安装可能解决问题.", vbExclamation, "加载"
        Exit Sub
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'方法---根据胶片路径，打开胶片
'p_strFilmPath<string>[in]:图片路径
'p_strErr<string>[in,out]:错误信息
'返回值：TRUE（成功）  OR FALSE（失败）
Public Function InitPhoto(ByVal p_strFilmPath As String, ByRef p_strErr As String) As Boolean
On Error GoTo ErrHandler
    If p_strFilmPath = "" Then
        p_strErr = "p_strFilmPath为空!"
        InitPhoto = False
        Exit Function
    End If
    dcmPhotoExamine.FreeMemory
    
    If Trim(p_strFilmPath) = "" Or Dir(p_strFilmPath, vbArchive) = "" Then
        dcmPhotoExamine.OpenFile DEFAULT_FILM_PATH
        dcmPhotoExamine.ImageZoomBestFit = True
    Else
        dcmPhotoExamine.OpenFileNameByMultiple = p_strFilmPath
    End If
    Pause 500
    
    '行数
    m_nRows = 1
    
    '列数
    m_nCols = 1
    'If iCount > 1 Then
    If dcmPhotoExamine.ImageSlicesTotal > 1 Then
        Select Case dcmPhotoExamine.ImageSlicesTotal
        Case 1:
            m_nCols = 1
            m_nRows = 1
        Case 2:
            m_nCols = 2
            m_nRows = 1
        Case 3, 4:
            m_nCols = 2
            m_nRows = 2
        Case 5, 6:
            m_nCols = 3
            m_nRows = 2
        Case 7, 8, 9:
            m_nCols = 3
            m_nRows = 3
        Case 10, 11, 12
             m_nCols = 4
            m_nRows = 3
        Case 13, 14, 15, 16
             m_nCols = 4
            m_nRows = 4
        Case 17, 18, 19, 20
            m_nCols = 5
            m_nRows = 4
        Case 21, 22, 23, 24, 25
            m_nCols = 5
            m_nRows = 5
        Case 26, 27, 28, 29, 30
            m_nCols = 6
            m_nRows = 5
        Case 31, 32, 33, 34, 35, 36
            m_nCols = 6
            m_nRows = 6
        Case 37, 38, 39, 40, 41, 42
            m_nCols = 7
            m_nRows = 6
        Case 43, 44, 45, 46, 47, 48, 49
            m_nCols = 7
            m_nRows = 7
        Case 50, 51, 52, 53, 54, 55, 56
            m_nCols = 8
            m_nRows = 7
        Case 57, 58, 59, 60, 61, 62, 63, 64
            m_nCols = 8
            m_nRows = 8
        Case 65, 66, 67, 68, 69, 70, 71, 72
            m_nCols = 9
            m_nRows = 8
        Case Else
            m_nCols = 9
            m_nRows = 9
        End Select
    End If

    iCount = dcmPhotoExamine.ImageSlicesTotal
    
    
    '此处应用紧接着的一行，而不是4，4，1，dcmPhotoExamine.ImageSlicesTotal
'    dcmPhotoExamine.ImageMosaicX m_nCols, m_nRows, 1, dcmPhotoExamine.ImageSlicesTotal


    dcmPhotoExamine.ImageMosaicX 4, 4, 1, dcmPhotoExamine.ImageSlicesTotal
    dcmPhotoExamine.ImageZoomBestFit = True
    dcmPhotoExamine.ImageTool = 14

    InitPhoto = True
    Exit Function
ErrHandler:
    p_strErr = Err.Description
    InitPhoto = False
End Function

Private Sub Form_Unload(Cancel As Integer)
On Error GoTo ErrHandler
    dcmPhotoExamine.FreeMemory
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
    
End Sub




'方法---根据胶片路径，打开胶片
'p_strFilmPath<string>[in]:图片路径
'p_strErr<string>[in,out]:错误信息
'返回值：TRUE（成功）  OR FALSE（失败）
Public Function InitFilmDSA(ByVal p_strFilmPath As String, ByRef p_strErr As String) As Boolean
On Error GoTo ErrHandler
    If p_strFilmPath = "" Then
        p_strErr = "p_strFilmPath为空!"
        InitFilmDSA = False
        Exit Function
    End If
    dcmPhotoExamine.FreeMemory
    
    If Trim(p_strFilmPath) = "" Or Dir(p_strFilmPath, vbArchive) = "" Then
        dcmPhotoExamine.OpenFile DEFAULT_FILM_PATH
        dcmPhotoExamine.ImageZoomBestFit = True
    Else
        dcmPhotoExamine.OpenFileNameByMultiple = p_strFilmPath
    End If
    Pause 500
   

    dcmPhotoExamine.ImageZoomBestFit = True
    dcmPhotoExamine.ImageTool = 14

    InitFilmDSA = True
    Exit Function
ErrHandler:
    p_strErr = Err.Description
    InitFilmDSA = False
End Function

Private Sub tmrPlaySlice_Timer()
    On Error GoTo ErrHandler

    '播放多帧DICOM文件 DCMSlice为当前显示的图像序列,DCMImageSlices为图像总序列数
    If dcmPhotoExamine.ImageSlicesCurrent < dcmPhotoExamine.ImageSlicesTotal Then
        dcmPhotoExamine.ImageSlicesCurrent = dcmPhotoExamine.ImageSlicesCurrent + 1
    Else
        dcmPhotoExamine.ImageSlicesCurrent = 1
    End If

    Exit Sub
ErrHandler:
End Sub








'方法---根据胶片路径，打开胶片
'p_strFilmPath<string>[in]:图片路径
'p_strErr<string>[in,out]:错误信息
'返回值：TRUE（成功）  OR FALSE（失败）
Public Function InitFilmDR(ByVal p_strFilmPath As String, ByRef p_strErr As String) As Boolean
On Error GoTo ErrHandler
    If p_strFilmPath = "" Then
        p_strErr = "p_strFilmPath为空!"
        InitFilmDR = False
        Exit Function
    End If
    dcmPhotoExamine.FreeMemory
    
    If Trim(p_strFilmPath) = "" Or Dir(p_strFilmPath, vbArchive) = "" Then
        dcmPhotoExamine.OpenFile DEFAULT_FILM_PATH
        dcmPhotoExamine.ImageZoomBestFit = True
    Else
        dcmPhotoExamine.OPENFILENAME = p_strFilmPath
    End If
    Pause 500
   
    dcmPhotoExamine.ImageZoomBestFit = True
    dcmPhotoExamine.ImageTool = 14

    InitFilmDR = True
    Exit Function
ErrHandler:
    p_strErr = Err.Description
    InitFilmDR = False
End Function