frmavicapture.frm

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

      Height          =   240
      Left            =   0
      Picture         =   "frmAviCapture.frx":6576
      Top             =   735
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imgHasSound 
      Height          =   240
      Left            =   30
      Picture         =   "frmAviCapture.frx":66C0
      Top             =   450
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image imgTrue 
      Height          =   240
      Left            =   15
      Picture         =   "frmAviCapture.frx":67C2
      Top             =   180
      Visible         =   0   'False
      Width           =   240
   End
End
Attribute VB_Name = "frmVideoCapture"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public Loaded As Boolean

Private US_NO As String         '超声序号
Private CurrentID As Integer    '当前的文件
Private bInRecording As Boolean '正在录音中的标志，防止chkSound重复操作
Dim strVideo As String          '视频文件名
Dim Id As Integer               '图象文件的序号
Private VideoID As Integer      '视频文件的序号
Private lFrames As Long         '已捕捉的帧数

Private HasCapture As Boolean   '已经采集了图片的标志
Public bNormalExit As Boolean   '是否正常退出的指示


Public LoadExist As Boolean     '是否加载已经存在的当前报告

Public bChangingImage As Boolean    '正在切换的标志

Private Sub chkPrint_Click()
    
    Dim MaxPrint As Integer
    
    '检查是否大于最大允许的打印张数
    If chkPrint.Value = 1 And ibPic.TagPrintNumber >= MAX_PRINT_IMAGES And ibPic.SelectedImage.TagPrint = False Then
        MsgBox "最多只能打印 " & MAX_PRINT_IMAGES & " 幅图片!", vbOKOnly + vbInformation, "提示"
        chkPrint.Value = 0
        Exit Sub
    End If

    '--------------------------
    '切换ibPic中选择图片的打印属性
    '--------------------------

    ibPic.SelectedImage.TagPrint = (chkPrint.Value = vbChecked)
    ibPic.ShowImage
    ibPic_SelectChanged     '刷新各选项的显示
    
End Sub

Private Sub chkSave_Click()
    
    '--------------------------
    '切换ibPic中选择图片的保存属性
    '--------------------------
    
    ibPic.SelectedImage.TagSave = (chkSave.Value = vbChecked)
    ibPic.ShowImage
    ibPic_SelectChanged     '刷新各选项的显示
    
End Sub

Private Sub chkSlowScan_Click()
    
    '-------------------
    '设置慢速扫描
    '-------------------
    
    wvAvi.StillMode = chkSlowScan.Value
    
End Sub

Private Sub chkSound_Click()
    
    '--------------------------
    '切换ibPic中选择图片的保存属性
    '--------------------------
    
    If bChangingImage Then Exit Sub
    
    If Not bInRecording Then   '如果是在录音中引发的Click事件则自动弹出录音窗体(因已经弹出了)
    
        If chkSound.Value = vbChecked Then
            cmdImageSound_Click
            If frmSoundRecord.Cancel Then chkSound.Value = 0: Exit Sub
        End If
    End If
    
    ibPic.SelectedImage.TagSound = (chkSound.Value = vbChecked)
    ibPic.ShowImage
    ibPic_SelectChanged

End Sub

Private Sub cmdCancel_Click()
    
    '-----------------------
    '取消
    '-----------------------
    
    Unload Me
    
End Sub

Private Sub cmdFormat_Click()
    
    wvAvi.ShowSourceDialog
    
    Me.wvVidX.SetZoom 50
    
End Sub

Private Sub cmdDeleteVideo_Click()
    
    '----------------------------------
    '删除当前的视频
    '----------------------------------
    If Not (lvwVideo.SelectedItem Is Nothing) Then
        lvwVideo.ListItems.Remove lvwVideo.SelectedItem.Index
    End If
    
End Sub

Private Sub cmdImageSound_Click()
    
    '-------------
    '录音
    '-------------
    
    bInRecording = True
    
    With frmSoundRecord
        .FileName = ImageFileToSoundFile(ibPic.SelectedImage.FileFullName)
        If FSO.FileExists(.FileName) Then Kill .FileName
        .Show vbModal
        '如果有录音,则加入,如果没有录音,则清空
        If FSO.FileExists(.FileName) And .Cancel = False Then
            ibPic.SelectedImage.TagSound = True
            ibPic.SelectedImage.SoundFile = .FileName
            ibPic_SelectChanged
            ibPic.ShowImage
        Else
        
        End If
    End With
    
    '释放对象
    bInRecording = False
    
End Sub

Private Sub cmdOK_Click()
    
    '---------
    '确定
    '---------
    Dim cIF As ImageFile
    Dim IFTemp As ImageFile
    Dim itmX As ListItem
    
    '如果与报告联合，则将图象信息写到frmReport窗体
    If US_NO <> vbNullString Then
        With frmReport
            '保存视频集合VFs
            If chkSaveVideo.Value = 1 Then
                For Each itmX In lvwVideo.ListItems
                    Set IFTemp = .VFs.Add(itmX.Tag)
                    IFTemp.Frames = itmX.SubItems(2)
                    If USV.AllowAudio Then IFTemp.SoundFile = itmX.ListSubItems(3).Tag
                Next itmX
            End If
            
            '先清除原先的IF集合
            Set .IFs = New ImageFiles
            For Each cIF In ibPic.ImageFiles
                If Me.ibPic.ShowAttachInfo Then
                    If cIF.TagSave Then
                        Set IFTemp = .IFs.Add(cIF.FileFullName)
                        IFTemp.TagSound = cIF.TagSound
                        IFTemp.TagSave = cIF.TagSave
                        IFTemp.TagPrint = cIF.TagPrint
                        If USV.AllowAudio Then IFTemp.SoundFile = cIF.SoundFile
                    End If
                Else
                    .IFs.Add cIF.FileFullName
                End If
            Next cIF
        End With
    End If

    '释放对象
    Set cIF = Nothing
    Set IFTemp = Nothing
    
    bNormalExit = True
    Unload Me
    
End Sub

Private Sub cmdPlay_Click()
    
    '---------
    '回放视频
    '---------
    
    If cmdPlay.Visible = False Or cmdPlay.Enabled = False Then Exit Sub
    
    wvAvi.Enabled = False
    
    '检查是否有选中的条目
    If lvwVideo.SelectedItem Is Nothing Then
        Exit Sub
    End If
    
    '播放视频
    Screen.MousePointer = vbHourglass
    frmVideoView.FileName = lvwVideo.SelectedItem.Tag
    frmVideoView.Show vbModal
    
    wvAvi.Enabled = True
    wvAvi.Startup
    
End Sub

Private Sub cmdPlayVideoSound_Click()
    
        
    '-------------------------------
    '播放选择项目的声音
    '-------------------------------
            
    Dim strFile As String
        
    With lvwVideo
        If .SelectedItem Is Nothing Then
            Exit Sub
        End If
        
        strFile = .SelectedItem.ListSubItems(3).Tag
        '如果该文件存在,则先删除
        If FSO.FileExists(strFile) Then
            PlaySound strFile
        End If
        
    End With

End Sub

Private Sub cmdSaveAs_Click()
    
    '--------------
    '当前图片另存为
    '--------------
    ibPic.SaveAs
    
End Sub

Private Sub cmdStartCapture_Click()

    If cmdStartCapture.Visible = False Or cmdStartCapture.Enabled = False Then Exit Sub
    
    NullCheck
    
    '-------------
    '开始捕捉图像
    '-------------
    
    '初始化视频序列号
    wvAvi.VideoFileName = GetFreeAviFileName
    
    lFrames = 0
    
    Me.StartCapture
    
    cmdStartCapture.Enabled = False
    cmdStopCapture.Enabled = True
    cmdStillImage.Enabled = False
    cmdPlay.Enabled = False
    cmdVideoProp.Enabled = False
    
End Sub

Private Sub cmdStillImage_Click()

    If cmdStillImage.Visible = False Or cmdStillImage.Enabled = False Then Exit Sub
    
    CheckDog
    
    '--------------
    '静态图片
    '--------------
    StillCapture (chkCopyFrame.Value = 1)
    
End Sub

Private Sub cmdStopCapture_Click()

    If cmdStopCapture.Visible = False Or cmdStopCapture.Enabled = False Then Exit Sub
    
    '-----------------------
    '停止捕捉,设置一些属性
    '-----------------------
    
    Screen.MousePointer = vbHourglass
    
    Me.StopCapture
    lblInfo.Caption = vbNullString
    
    chkSaveVideo.Enabled = True
    chkSaveVideo.Value = 1
    chkSaveVideo.Tag = "HasVideo"
    
    cmdStopCapture.Enabled = False
    cmdStartCapture.Enabled = True
    cmdStillImage.Enabled = True
    cmdPlay.Enabled = True
    cmdVideoProp.Enabled = True

    cmdVideoSound.Enabled = True
    
    '捕捉并恢复鼠标
    VideoCapture
    Screen.MousePointer = vbNormal
    
End Sub


Private Sub cmdVideoProp_Click()

    If cmdVideoProp.Visible = False Or cmdVideoProp.Enabled = False Then Exit Sub
    
    '-----------------
    '显示属性窗体
    '-----------------
    
    If frmReport.Loaded Then
        frmVideoProp.Show vbModal
    Else
        frmVideoProp.Show , frmMain
    End If
End Sub

Private Sub cmdVideoSound_Click()
    
    '------------------
    '保存对视频的配音
    '------------------
    
    Dim strFile
    On Error Resume Next
    
    
    With lvwVideo
        If .SelectedItem Is Nothing Then
            Exit Sub
        End If
        
        strFile = Left(.SelectedItem.Tag, Len(.SelectedItem.Tag) - 4) & "X.WAV"
        
        '如果该文件存在,则先删除
        If FSO.FileExists(strFile) Then Kill strFile
        With frmSoundRecord
            .FileName = strFile
            .Show vbModal
        End With
        '如果该文件存在并且不是取消，则记录
        If FSO.FileExists(strFile) And frmSoundRecord.Cancel = False Then
            .SelectedItem.ListSubItems(3).ReportIcon = "Sound"
            .SelectedItem.ListSubItems(3).Tag = strFile
        Else
            .SelectedItem.ListSubItems(3).ReportIcon = 0
            .SelectedItem.ListSubItems(3).Tag = vbNullString
        End If
        
    End With
    
    
    '释放对象
    
    
End Sub



Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    
    '---------------
    '处理键盘事件
    '---------------
    
    Select Case KeyCode
        Case vbKeyF2
            cmdStartCapture_Click
        Case vbKeyF3
            cmdStopCapture_Click
        Case vbKeyF4
            cmdStillImage_Click
        Case vbKeyF5
            cmdPlay_Click
        Case vbKeyF6
            cmdVideoProp_Click
        Case vbKeyEscape
            Unload Me
    End Select
    
End Sub

Private Sub Form_Load()
    
    '-------------------
    '窗体加载
    '-------------------
    
    '根据版本判断是否应该加载窗体
    If USV.AllowCapture = False Then
        Unload Me
        Exit Sub
    End If
    
    NullCheck

    Dim cIF As ImageFile
    Dim IFTemp As ImageFile
    Dim itmX As ListItem
    
    '根据版本判断是否应该显示功能
    If USV.AllowAudio = False Then
        Me.cmdVideoSound.Visible = False
        Me.cmdPlayVideoSound.Visible = False
        Me.chkSound.Visible = False
        Me.lblSound.Visible = False
        Me.cmdImageSound.Visible = False
        lvwVideo.ColumnHeaders.Remove (4)
    End If
    
    '如果不能保存视频，则应该不显示视频属性
    If USV.AllowSaveVideo = False Then
        Dim Delta
        Frame1.Visible = False
        lvwVideo.Visible = False
        Delta = Frame2.Top - Frame1.Top
        Frame2.Top = Frame2.Top - Delta