frmimageedit.frm

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

        
        Case "浮雕"
            Dx = 1
            Dy = 1
            For i = 1 To y - 2
                For j = 1 To x - 2
                    r = Abs(IP(0, j, i) - IP(0, j + Dx, i + Dy) + 128)
                    G = Abs(IP(1, j, i) - IP(1, j + Dx, i + Dy) + 128)
                    B = Abs(IP(2, j, i) - IP(2, j + Dx, i + Dy) + 128)
                    picMirror.PSet (j, i), RGB(r, G, B)
                Next j
                pbr.Value = i + y
            Next i
           
        Case "雕刻"
            Dx = -1
            Dy = -1
            For i = 1 To y - 2
                For j = 1 To x - 2
                    r = Abs(IP(0, j, i) - IP(0, j + Dx, i + Dy) + 128)
                    G = Abs(IP(1, j, i) - IP(1, j + Dx, i + Dy) + 128)
                    B = Abs(IP(2, j, i) - IP(2, j + Dx, i + Dy) + 128)
                    picMirror.PSet (j, i), RGB(r, G, B)
                Next j
                pbr.Value = i + y
            Next i
           
        Case "柔化"
            For i = 1 To y - 2
                For j = 1 To x - 2
                    r = (IP(0, j - 1, i - 1) + IP(0, j - 1, i) + IP(0, j - 1, i + 1) + IP(0, j, i - 1) + IP(0, j, i) + IP(0, j, i + 1) + IP(0, j + 1, i - 1) + IP(0, j + 1, i) + IP(0, j + 1, i + 1)) / 9
                    G = (IP(1, j - 1, i - 1) + IP(1, j - 1, i) + IP(1, j - 1, i + 1) + IP(1, j, i - 1) + IP(1, j, i) + IP(1, j, i + 1) + IP(1, j + 1, i - 1) + IP(1, j + 1, i) + IP(1, j + 1, i + 1)) / 9
                    B = (IP(2, j - 1, i - 1) + IP(2, j - 1, i) + IP(2, j - 1, i + 1) + IP(2, j, i - 1) + IP(2, j, i) + IP(2, j, i + 1) + IP(2, j + 1, i - 1) + IP(2, j + 1, i) + IP(2, j + 1, i + 1)) / 9
                    picMirror.PSet (j, i), RGB(r, G, B)
                Next j
                pbr.Value = i + y
            Next i
           
         Case "锐化"
            Dx = 1
            Dy = 1
            A = 0.5
            For i = 1 To y - 2
                For j = 1 To x - 2
                    r = IP(0, j, i) + A * (IP(0, j, i) - IP(0, j - Dx, i - Dy))
                    G = IP(1, j, i) + A * (IP(1, j, i) - IP(1, j - Dx, i - Dy))
                    B = IP(2, j, i) + A * (IP(2, j, i) - IP(2, j - Dx, i - Dy))
                    CheckRGB r
                    CheckRGB G
                    CheckRGB B
                    picMirror.PSet (j, i), RGB(r, G, B)
                Next j
                pbr.Value = i + y
            Next i
           
        Case "发散"
            Dim Rx As Integer, Ry As Integer
            For i = 2 To y - 3
                For j = 2 To x - 3
                    Rx = Rnd * 4 - 2
                    Ry = Rnd * 4 - 2
                    r = IP(0, j + Rx, i + Ry)
                    G = IP(1, j + Rx, i + Ry)
                    B = IP(2, j + Rx, i + Ry)
                    picMirror.PSet (j, i), RGB(r, G, B)
                Next j
                pbr.Value = i + y
            Next i
        
        Case "边缘"
            F(0, 0) = 0
            F(1, 0) = 0
            F(2, 0) = 0
            F(0, 1) = 1
            F(1, 1) = -1
            F(2, 1) = 0
            F(0, 2) = 0
            F(1, 2) = 0
            F(2, 2) = 0
            Divide = 9
            Blas = 128
            For i = 1 To y - 2
                For j = 1 To x - 2
                    r = (F(0, 0) * IP(0, j - 1, i - 1) + F(1, 0) * IP(0, j, i - 1) + F(2, 0) * IP(0, j + 1, i - 1) + F(0, 1) * IP(0, j - 1, i) + F(1, 1) * IP(0, j, i) + F(2, 1) * IP(0, j + 1, i) + F(0, 2) * IP(0, j - 1, i + 1) + F(1, 2) * IP(0, j, i + 1) + F(2, 2) * IP(0, j + 1, i + 1)) / Divide + Blas
                    G = (F(0, 0) * IP(1, j - 1, i - 1) + F(1, 0) * IP(1, j, i - 1) + F(2, 0) * IP(1, j + 1, i - 1) + F(0, 1) * IP(1, j - 1, i) + F(1, 1) * IP(1, j, i) + F(2, 1) * IP(1, j + 1, i) + F(0, 2) * IP(1, j - 1, i + 1) + F(1, 2) * IP(1, j, i + 1) + F(2, 2) * IP(1, j + 1, i + 1)) / Divide + Blas
                    B = (F(0, 0) * IP(2, j - 1, i - 1) + F(1, 0) * IP(2, j, i - 1) + F(2, 0) * IP(2, j + 1, i - 1) + F(0, 1) * IP(2, j - 1, i) + F(1, 1) * IP(2, j, i) + F(2, 1) * IP(2, j + 1, i) + F(0, 2) * IP(2, j - 1, i + 1) + F(1, 2) * IP(2, j, i + 1) + F(2, 2) * IP(2, j + 1, i + 1)) / Divide + Blas
                    CheckRGB r
                    CheckRGB G
                    CheckRGB B
                    picMirror.PSet (j, i), RGB(r, G, B)
                Next j
                pbr.Value = i + y
            Next i
            
        Case "增亮"
            Delta = 1.1
            For i = 0 To y - 1
                For j = 0 To x - 1
                    r = IP(0, j, i) * Delta
                    G = IP(1, j, i) * Delta
                    B = IP(2, j, i) * Delta
                    CheckRGB r
                    CheckRGB G
                    CheckRGB B
                    picMirror.PSet (j, i), RGB(r, G, B)
                Next j
                pbr.Value = i + y
            Next i

        Case "暗化"
            Delta = 1 / 1.1
            For i = 0 To y - 1
                For j = 0 To x - 1
                    r = IP(0, j, i) * Delta
                    G = IP(1, j, i) * Delta
                    B = IP(2, j, i) * Delta
                    CheckRGB r
                    CheckRGB G
                    CheckRGB B
                    picMirror.PSet (j, i), RGB(r, G, B)
                Next j
                pbr.Value = i + y
            Next i
        
    End Select
    
    '-------------
    '完成处理
    '-------------
    
    '调用ScaleImage方法自动处理缩放的情况
    ScaleImage
    ShowProgress False
    Screen.MousePointer = vbNormal
    
End Sub

Private Sub CheckRGB(ByRef RGBValue As Integer)
    
    If RGBValue > 255 Then RGBValue = 255
    If RGBValue < 0 Then RGBValue = 0
    
End Sub

Private Sub cmdFilter_Click()
            
    '---------------------------------
    '按照指定滤镜过滤(3*3)
    '---------------------------------
    Dim A(8) As Single
    Dim Dx As Integer, Dy As Integer, i As Long, j As Long
    Dim r As Integer            '红色变量
    Dim G As Integer            '绿色变量
    Dim B As Integer            '蓝色变量
    
    Screen.MousePointer = vbHourglass
    
    A(0) = txtFilter(0).Text
    A(1) = txtFilter(1).Text
    A(2) = txtFilter(2).Text
    A(3) = txtFilter(3).Text
    A(4) = txtFilter(4).Text
    A(5) = txtFilter(5).Text
    A(6) = txtFilter(6).Text
    A(7) = txtFilter(7).Text
    A(8) = txtFilter(8).Text
    
    '保存备份
    picBak.Picture = picMirror.Picture
    
    '读取颜色数组
    ReadImage
    
    Dx = -1
    Dy = -1
    For i = 1 To y - 2
        For j = 1 To x - 2
            
            r = (A(0) * IP(0, j - Dx, i - Dy) + A(1) * IP(0, j, i - Dy) + A(2) * IP(0, j + Dx, i - Dy) + A(3) * IP(0, j - Dx, i) + A(4) * IP(0, j, i) + A(5) * IP(0, j + Dx, i) + A(6) * IP(0, j - Dx, i + Dy) + A(7) * IP(0, j, i + Dy) + A(8) * IP(0, j + Dx, i + Dy))
            G = (A(0) * IP(1, j - Dx, i - Dy) + A(1) * IP(1, j, i - Dy) + A(2) * IP(1, j + Dx, i - Dy) + A(3) * IP(1, j - Dx, i) + A(4) * IP(1, j, i) + A(5) * IP(1, j + Dx, i) + A(6) * IP(1, j - Dx, i + Dy) + A(7) * IP(1, j, i + Dy) + A(8) * IP(1, j + Dx, i + Dy))
            B = (A(0) * IP(2, j - Dx, i - Dy) + A(1) * IP(2, j, i - Dy) + A(2) * IP(2, j + Dx, i - Dy) + A(3) * IP(2, j - Dx, i) + A(4) * IP(2, j, i) + A(5) * IP(2, j + Dx, i) + A(6) * IP(2, j - Dx, i + Dy) + A(7) * IP(2, j, i + Dy) + A(8) * IP(2, j + Dx, i + Dy))
    
            CheckRGB r
            CheckRGB G
            CheckRGB B
            
            picMirror.PSet (j, i), RGB(r, G, B)
        Next j
        pbr.Value = i + y
    Next i

    '-------------
    '完成处理
    '-------------
    
    '调用ScaleImage方法自动处理缩放的情况
    ScaleImage
    ShowProgress False
    Screen.MousePointer = vbNormal

End Sub

Private Sub cmdFlip_Click()
    '翻转
    On Error GoTo ErrHandle
    
    picBak.Picture = picImage.Image
    'With picImage
    With picMirror
        Select Case True
            Case optFlip(0).Value
                .PaintPicture .Picture, 0, 0, .ScaleWidth, .ScaleHeight, .ScaleWidth, 0, -.ScaleWidth, .ScaleHeight, vbSrcCopy
            Case optFlip(1).Value
                .PaintPicture .Picture, 0, 0, .ScaleWidth, .ScaleHeight, 0, .ScaleHeight, .ScaleWidth, -.ScaleHeight, vbSrcCopy
            Case optFlip(2).Value
                .PaintPicture .Picture, 0, 0, .ScaleWidth, .ScaleHeight, .ScaleWidth, .ScaleHeight, -.ScaleWidth, -.ScaleHeight, vbSrcCopy
        End Select
        .Picture = .Image
    End With
    
    ScaleImage
    
    Exit Sub

ErrHandle:
    MsgBox "抱歉，对于当前的图象，不能进行翻转操作。", vbOKOnly + vbInformation, "提示"

End Sub

Private Sub cmdMark_Click()
    
'    '图像标注,调用画笔(可以允许用户设置)
'    Dim strTempFile As String
'
'    strTempFile = App.Path & "\TEMP\TEMP.BMP"
'    picBak.Picture = picImage.Picture
'    SavePicture picImage.Picture, strTempFile
'    ShellWait App.Path & "\MSPAINT.EXE " & strTempFile
'    picImage.Picture = LoadPicture(strTempFile)
    
    picMirror.Line (2, 2)-(30, 30), vbYellow, BF
    picMirror.Picture = picMirror.Image
    'picImage.Image = picImage.Picture
    ScaleImage
    
End Sub

Private Sub cmdMarkPaint_Click()
    
    '图像标注,调用画笔(可以允许用户设置)
    Dim strTempFile As String

    strTempFile = App.Path & "\TEMP\TEMP.BMP"
    picBak.Picture = picImage.Image
    picImage.Picture = picImage.Image
    SavePicture picImage.Picture, strTempFile
    ShellWait App.Path & "\MSPAINT.EXE " & """" & strTempFile & """"
    picImage.Picture = LoadPicture(strTempFile)

End Sub

Private Sub cmdOK_Click()
    '确定
    cmdSave_Click
    Unload Me
End Sub

Private Sub cmdOpen_Click()
    
    '打开文件并读取像素
    cdlOpen.ShowOpen
    If cdlOpen.FileName > vbNullString Then
        FileName = cdlOpen.FileName
        LoadImage FileName
    Else
        Exit Sub
    End If
    
    
    '自动调整大小
'    With picImage
'        If .Width > Me.Width Then Me.Width = .Width + 300
'        If .Height > Me.Height - picEdit.Height + 300 Then Me.Height = .Height + picEdit.Height + 600
'    End With
    
End Sub

Private Sub ReadImage()
    
    Dim i As Long
    Dim j As Long
    Dim P As Long
    
    '读取像素
    With picMirror
        Screen.MousePointer = vbHourglass
        picBak.Picture = picMirror.Image
        x = .ScaleWidth
        y = .ScaleHeight
        ReDim IP(2, x, y)
        ShowProgress True
        pbr.Max = y * 2
        For i = 0 To y - 1
            For j = 0 To x - 1
                P = .Point(j, i)
                IP(0, j, i) = GetRed(P)
                IP(1, j, i) = GetGreen(P)
                IP(2, j, i) = GetBlue(P)
            Next j
            pbr.Value = i
            DoEvents
        Next i
        'Debug.Print X, Y
    End With
    'ShowProgress False
    sbrEdit.Panels("Info").Text = "图像尺寸: " & x & " × " & y
    Screen.MousePointer = vbNormal
    
End Sub

Private Function GetRed(lColor) As Long
    '返回红色值
    GetRed = lColor Mod 256
End Function

Private Function GetGreen(lColor) As Long
    '返回绿色值
    GetGreen = ((lColor And &HFF00) / 256) Mod 256
End Function
    
Private Function GetBlue(lColor) As Long
    '返回蓝色值
    GetBlue = (lColor And &HFF0000) / 65536
End Function

Private Sub cmdPrint_Click()
    
    '---------------
    '打印单幅图片
    '---------------
    
    Dim strFile As String
    Dim strHTML As String
    Dim strTemp As String
    Dim strTempFile As String
    Dim strImage As String
    Dim strTempImageFile  As String
    
    Dim cTR As New TextReplace
    Dim tst As TextStream
    Dim cTRTemp As New TextReplace
    Dim i As Integer
    
    '先保存文件
    strTempImageFile = App.Path & "\TEMP\TEMP.BMP"
    picBak.Picture = picImage.Picture
    SavePicture picImage.Picture, strTempImageFile
    
    '加载模版文件
    strFile = App.Path & "\REPORT\TEMPLATE\SINGLEIMAGEPRINT.HTM"
    strTempFile = App.Path & "\REPORT\SINGLEIMAGEPRINT.HTM"
    strHTML = FSO.OpenTextFile(strFile).ReadAll
    
    If frmReport.Loaded Then
        With frmReport
            TagString = "超声号：" & .txtUSNo.Text
            TagString = TagString & "　　病人姓名：" & .txtSickName.Text
        End With
    Else
        'TagString = "超声号：　　　　　　　　　 病人姓名："
        TagString = vbNullString
    End If
    
    With cTR
        .Text = strHTML
        '请在这句修改单幅图片的宽度和高度
        strImage = "<img width=""288"" height=""252"" src=""FILE:///" & strTempImageFile & """" & ">"
        .Replace "PICTURE", strImage
        .Replace "\", "/"
        .Replace "INFO", Me.TagString
    End With
    
    Set tst = FSO.CreateTextFile(strTempFile)
    tst.Write cTR.Text
    
    With frmReportPreview
        .FileName = strTempFile
        .Show vbModal
    End With
    
    '释放对象
    tst.Close
    Set tst = Nothing
    Set cTR = Nothing

End Sub

Private Sub cmdReload_Click()
    
    '---------------------
    '重新载入文件
    '---------------------
    
    LoadImage FileName
    
End Sub

Private Sub cmdSave_Click()

    '---------------------
    '保存文件
    '---------------------
    picImage.Picture = picImage.Image
    
    '图像编辑只能保存为BMP格式
    If UCase(Right(Me.FileName, 3)) = "JPG" Then
        
        Me.FileName = Left(Me.FileName, Len(Me.FileName) - 3) & "BMP"
        SavePicture picImage.Picture, Me.FileName
        
        With frmVideoCapture
            .ibPic.SelectedImage.FileFullName = Me.FileName
            .ibPic.ShowImage                                        '重载图像及相关属性
            .ibPic_SelectChanged                                    '更新相关信息
        End With
        
        Exit Sub