frmavicapture.frm

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

        Frame3.Top = Frame3.Top - Delta
        Frame4.Top = Frame4.Top - Delta
        ibPic.Top = ibPic.Top - Delta
    End If
    
    '初始化捕捉控件
    Dim HWndCapture As Long
    HWndCapture = wvAvi.Startup
    wvVidX.Startup HWndCapture
    
    SetLvwPlainHead lvwVideo, Me.hwnd
    
    '表明本窗体已经加载
    Loaded = True
    
    'IniUS.LoadFormPlace Me
    Me.WindowState = 2
        
    Id = 0
        
    '设置视频属性
    SetVideoProp
    
    '判断frmReport是否加载
    With frmReport
        'If .Loaded And .WorkType = "Add" Then
        If .Loaded Then
            If .txtUSNo.Text = vbNullString Then
                MsgBox "请在信息窗体中输入合法的超声号！", vbInformation + vbOKOnly, "提示"
                Unload Me
                Exit Sub
            Else
                US_NO = .txtUSNo.Text
                Me.sbrPicView.Panels("US_NO").Text = "当前超声号: " & US_NO
                
            End If
        Else
            US_NO = vbNullString
            Me.sbrPicView.Panels("US_NO").Text = "独立图象捕捉"
        End If
    End With
    
    '根据US_NO是否为空判断目前的状态
    If US_NO <> vbNullString Then
        wvAvi.VideoFileName = gstrTempDir & "\" & US_NO & "_1X.AVI"
        
'        '对已经采集过的视频，导入进来
'        If FSO.FileExists(wvAvi.VideoFileName) And frmReport.VideoFileName <> vbNullString Then
'            cmdPlay.Enabled = True
'            chkSaveVideo.Enabled = True
'            chkSaveVideo.Value = 1
'        End If
        
        Dim iTemp As Integer
        
        With frmReport
            '对已经采集过的视频，导入进来
            lvwVideo.ListItems.Clear
            For Each cIF In .VFs
                
            Next cIF
        
        
            '对已经采集过的图象，导入进来
            '先清除原先的IF集合
            ibPic.ImageFiles.Clear
            For Each cIF In .IFs
                If Me.ibPic.ShowAttachInfo Then
                    If cIF.TagSave Then
                        Set IFTemp = ibPic.ImageFiles.Add(cIF.FileFullName)
                        IFTemp.TagSound = cIF.TagSound
                        IFTemp.TagSave = cIF.TagSave
                        IFTemp.TagPrint = cIF.TagPrint
                        If USV.AllowAudio Then IFTemp.SoundFile = cIF.SoundFile
                        iTemp = Val(Mid(cIF.FileMainName, InStr(1, cIF.FileMainName, "_") + 1))
                        If iTemp > Id Then Id = iTemp
                    End If
                Else
                    .IFs.Add cIF.FileFullName
                End If
            Next cIF
            ibPic.ShowImage
        End With
    Else
        wvAvi.VideoFileName = gstrTempDir & "\1X.AVI"
    End If
    
    
    '设置屏幕鼠标
    Screen.MousePointer = vbNormal
    
End Sub

Public Sub StartCapture()
    
    '--------------
    '开始捕捉
    '--------------
    
    Dim ErrCode As Integer
        
    Screen.MousePointer = vbHourglass
        
    ErrCode = wvAvi.StartContinuousCapture
    If ErrCode > 0 Then
        MsgBox "由于错误: " & ErrCode & ", 该操作不能完成! ", vbOKOnly + vbExclamation, "错误"
    End If
    
    Screen.MousePointer = vbNormal
    
End Sub

Public Sub StopCapture()
    
    '-------------
    '开始捕捉
    '-------------
    
    Dim ErrCode As Integer
    
    ErrCode = wvAvi.StopCapture
    If ErrCode > 0 Then
        MsgBox "由于错误: " & ErrCode & ", 该操作不能完成! ", vbOKOnly + vbExclamation, "错误"
    End If
    
End Sub

Public Sub StillCapture(Optional UsingFrame As Boolean = False)
    
    '--------------
    '捕捉静态图象
    '--------------
    
    Dim ErrCode As Integer
    Dim strFile As String           '图形文件名
    Dim strFileExtension As String  '图形的后缀，根据是BMP还是JPG决定
        
    Select Case wvAvi.ImageFileFormat
        Case 0  'BMP
            strFileExtension = ".BMP"
        Case 1  'JPG
            strFileExtension = ".JPG"
        Case Else
    End Select
        
    Screen.MousePointer = vbHourglass
    
    Id = Id + 1
    
    '根据US_NO判断当前的状态
    If US_NO <> vbNullString Then
        'strFile = gstrTempDir & "\" & US_NO & "_" & Format(ID) & ".BMP"
        strFile = gstrTempDir & "\" & Format(Id) & strFileExtension
    Else
        strFile = gstrTempDir & "\" & Format(Id) & strFileExtension
    End If
    
    If UsingFrame Then
        ErrCode = wvAvi.CaptureFrameToFile(strFile)
    Else
        ErrCode = wvAvi.CaptureStillToFile(strFile)
    End If
    
    If ErrCode > 0 Or ErrCode = -2 Or ErrCode = -7 Then
        MsgBox "由于错误: " & ErrCode & ", 该操作不能完成! ", vbOKOnly + vbExclamation, "错误"
        Id = Id - 1
        Screen.MousePointer = vbNormal
        Exit Sub
    End If
        
    '加入到IB控件中
    Dim cIF As ImageFile
    
    Set cIF = ibPic.ImageFiles.Add(strFile)
    cIF.TagSave = True
    ibPic.ShowImage
    
    '设置已经采集图片的标志
    HasCapture = True

    Screen.MousePointer = vbNormal
    
    '释放对象的引用
    
End Sub

Public Sub SetVideoProp()
    
    '----------------------------
    '设置视频属性
    '----------------------------
    
    '读取视频设置
    With wvAvi
        .PreviewFrameRate = gintPreviewFrameRate
        .FrameRate = gintFrameRate
        .FrameLimit = glngFrameLimit
        .TimeLimit = glngTimeLimit
        '.VideoWidth = gintVideoWidth
        '.VideoHeight = gintVideoHeight
        .SetVideoWidthAndHeight gintVideoWidth, gintVideoHeight
        .StillHeight = gintStillHeight
        .StillWidth = gintStillWidth
        .VideoCodec = gstrVideoCodec
        .VideoQuality = 100 / gintVideoCompressRate
        .StillImageType = gintStillImageType
        .ImageFileFormat = gintStillImageFormat
        .EnableStatusEvents = True
        
        'Audio
        .AudioCaptureOn = gbAudioCaptureOn
        .AudioCaptureStereo = gbAudioCaptureStereo
        .AudioCapture8Bit = gbAudioCapture8Bit
        .AudioCaptureSampleRate = gintAudioCaptureSampleRate
        
        Me.sbrPicView.Panels("Info").Text = "视频: " & .VideoWidth & "x" & .VideoHeight & "    静态图象: " & .StillWidth & "x" & .StillHeight
        .Move 0, 0, .VideoWidth * Screen.TwipsPerPixelX, .VideoHeight * Screen.TwipsPerPixelY
        Form_Resize

    End With
    
    '调整VidX的设置
    With wvVidX
        .SetBrightness gintBrightness
        .SetContrast gintContrast
        .SetHue gintHue
        .SetSaturation gintSaturation
        .SetSource gintVideoSource
    End With
    
End Sub

Private Sub Form_Resize()
    
    '---------------------------------------
    '当窗体大小改变时,重新设置控件的位置
    '---------------------------------------
    
    On Error Resume Next
    
    fraVideo.Move 0, 0, Me.width - Picture1.width - 120 - 60, Me.height - Me.sbrPicView.height - Me.picCommand.height - 405
    wvAvi.Move (fraVideo.width - wvAvi.width) / 2, (fraVideo.height - wvAvi.height) / 2
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    
    '--------------
    '当窗体卸载时
    '--------------
    Dim Ret As Integer
    
    '如果有采图，则先询问是否真的退出
    If HasCapture And Not bNormalExit Then
        Ret = MsgBox("您已经采集了图片或视频，真的退出图象采集功能吗？", vbYesNo + vbQuestion, "确认退出")
        Select Case Ret
            Case vbYes
                
            Case vbNo
                Cancel = True
                Exit Sub
        End Select
    End If
    
    IniUS.SaveFormPlace Me
    
    '清空初始变量
    HasCapture = False
    bNormalExit = False
    
    Loaded = False
    CurrentID = 0
    Id = 0
    VideoID = 0
    lFrames = 0
    US_NO = vbNullString
    LoadExist = False
    
End Sub

Private Sub ibPic_ActionComplete()
    
    '将焦点转移到静态捕捉按钮上
    cmdOK.SetFocus

End Sub

Private Sub ibPic_BeforePrintSingleImage()
    
    '--------------------------
    '显示超声号和病人信息
    '--------------------------
    On Error GoTo ErrHandle
    
    ibPic.TagString = vbNullString
    
    '当打印单幅图片时，输入当前报告的信息(超声号和病人姓名)
    If frmReport.Loaded Then
        With frmReport
            ibPic.TagString = "超声号：" & .txtUSNo.Text
            ibPic.TagString = ibPic.TagString & "　　病人姓名：" & .txtSickName.Text
        End With
    End If
    
    Exit Sub

ErrHandle:
    Exit Sub

End Sub

Private Sub ibPic_Message(strMsg As String)
    
    '显示消息
    Me.sbrPicView.Panels("Pic").Text = strMsg

End Sub

Public Sub ibPic_SelectChanged()
    
    '当选择的图片发生变化时，要更新对应的复选框
    Dim bEnable As Boolean
    
    '当选择为单幅图片时允许显示
    bEnable = (ibPic.SelectedItems.Count = 1)
    chkSave.Enabled = bEnable
    chkSound.Enabled = bEnable
    chkPrint.Enabled = bEnable
    lblImage.Caption = vbNullString
    lblSound.Caption = vbNullString
    cmdSaveAs.Enabled = bEnable
    cmdImageSound.Enabled = bEnable
    
    '单幅图片时显示信息
    Dim cIF As ImageFile
    If bEnable Then
        Set cIF = ibPic.SelectedImage
        With cIF
            bChangingImage = True
            chkSave.Value = Abs(.TagSave)
            chkSound.Value = Abs(.TagSound)
            chkPrint.Value = Abs(.TagPrint)
            lblImage.Caption = .FileName
            If .TagSound Then lblSound.Caption = .FileMainName & ".WAV"
            bChangingImage = False
        End With
    End If
    
    '释放对象
    Set cIF = Nothing
    
End Sub

Private Sub lvwVideo_DblClick()
    
    '-----------------------------
    '等于播放
    '-----------------------------
    cmdPlay_Click
    
End Sub

Private Sub optPreview_Click(Index As Integer)
    '-----------------------------
    '设置预览的优先级
    '-----------------------------
       
    With wvAvi
        Select Case Index
            Case 0      '暂停
                .PreviewPriority = 0
                cmdStartCapture.Visible = False
                cmdStopCapture.Visible = True
                cmdStillImage.Visible = True
                cmdPlay.Visible = True
                cmdVideoProp.Visible = True
            
            Case 1      '正常
                .PreviewPriority = 50
                cmdStartCapture.Visible = True
                cmdStopCapture.Visible = True
                cmdStillImage.Visible = True
                cmdPlay.Visible = True
                cmdVideoProp.Visible = True
                
            Case 2      '高性能
                .PreviewPriority = 100
                cmdStartCapture.Visible = False
                cmdStopCapture.Visible = False
                cmdStillImage.Visible = False
                cmdPlay.Visible = False
                cmdVideoProp.Visible = False
        End Select
    End With

End Sub

Private Sub Picture1_Resize()
    
    '----------------------------
    '重设工具的位置
    '----------------------------
    
    ibPic.height = Picture1.ScaleHeight - ibPic.Top
    
End Sub

Private Sub wvAvi_CaptureStatus(ByVal Id As Long, ByVal message As String)
    
    '----------------------------
    '显示捕捉信息,记录帧数
    '----------------------------
    
    lblInfo.Caption = message
    lFrames = lFrames + 1
    
End Sub

Public Sub VideoCapture()
    
    '-----------------------------------
    '动态视频捕捉
    '-----------------------------------
    
    If FSO.FileExists(wvAvi.VideoFileName) = False Then Exit Sub
    Dim itmX As ListItem
    Set itmX = lvwVideo.ListItems.Add(, wvAvi.VideoFileName, GetFileName(wvAvi.VideoFileName), , "Video")
    itmX.Tag = wvAvi.VideoFileName
    itmX.SubItems(1) = Format(FileSize(wvAvi.VideoFileName), "###,###,###,###,###")
    itmX.SubItems(2) = Format(lFrames, "###,###,###,###,###")
    If USV.AllowAudio Then itmX.SubItems(3) = vbNullString
'    itmX.ListSubItems(3).ReportIcon = "Sound"
    
    Set lvwVideo.SelectedItem = itmX
    itmX.EnsureVisible
    lvwVideo.Refresh
    
    '设置已经采集图片的标志
    HasCapture = True
    
    
End Sub

Public Function GetFreeAviFileName()
    
    '-------------------------------
    '获取可使用的视频文件名称(在TempDir下)
    '-------------------------------
    Dim i As Long
    
    i = 1
    
    Do While FSO.FileExists(gstrTempDir & "\" & Format(i) & ".AVI")
        i = i + 1
    Loop
    
    GetFreeAviFileName = gstrTempDir & "\" & Format(i) & ".AVI"
    
End Function