imagebrowser.ctl

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

    '显示信息
    Dim strMsg As String
    strMsg = "共 " & ImageFiles.Count & " 个文件"
    If Me.SelectedItems.Count > 0 Then strMsg = strMsg & "； 选择了 " & Me.SelectedItems.Count & " 个文件。"
        
    ShowMSG strMsg

    Screen.MousePointer = vbNormal

    LockWindowUpdate 0
    
    '刷新图象
    picContainer.Refresh
    
End Sub

Public Property Get UnitWidth() As Integer
    
    '图像单元的宽
    UnitWidth = m_PicLeftMargin + picImage(0).width + Abs(m_ShowAttachInfo) * 300
    
End Property

Public Property Get UnitHeight() As Integer
    
    '图像单元的高
    UnitHeight = m_PicTopMargin + picImage(0).height + lblFileName(0).height + 30
    
End Property

Private Sub barIB_ToolClick(ByVal Tool As ActiveToolBars.SSTool)
    
    Select Case Tool.Id
        
        Case "ID_PrintSingle"
            Me.PrintSingleImage
        
        Case "ID_Print"
            Me.PrintImage False
            
        Case "ID_PrintAll"
            Me.PrintImage True
            
        Case "ID_Remove"
            Me.RemoveSelectedImages
            
        Case "ID_Delete"
            Me.DeleteSelectedImageFiles
        
        Case "ID_SaveAs"
            Me.SaveAs
                            
        Case "ID_SaveToPath"
            Me.SaveToPath
            
        Case "ID_TagSave"
            Me.TagSave True
            
        Case "ID_TagPrint"
            Me.TagPrint True
        
        Case "ID_TagSound"
            Me.TagSound True
        
        Case "ID_TagNoSave"
            Me.TagSave False
            
        Case "ID_TagNoPrint"
            Me.TagPrint False
            
        Case "ID_TagNoSound"
            Me.TagSound False
            
        Case "ID_SelectAll"
            Me.SelectAll
        
        Case "ID_UnSelect"
            Me.UnSelect
        
        Case "ID_Edit"
            If AutoEdit Then
                EditImage Me.SelectedImage.FileFullName
                Exit Sub
            End If

        
    End Select
    
    RaiseEvent ActionComplete
    RaiseEvent SelectChanged
    
End Sub

Public Function TagSave(bSave As Boolean)
    
    '----------------
    '切换保存的标记
    '----------------
    
    Dim i As Integer
    
    For i = 1 To Me.SelectedItems.Count
        Me.ImageFiles(Me.SelectedItems(i)).TagSave = bSave
    Next i
    ShowImage
    
End Function

Public Function TagSound(bSound As Boolean)
    
    '-----------------------
    '切换声音的标记
    '-----------------------
    
    Dim i As Integer
    
    For i = 1 To Me.SelectedItems.Count
        Me.ImageFiles(Me.SelectedItems(i)).TagSound = bSound
    Next i
    ShowImage

End Function

Public Function TagPrint(bPrint As Boolean)
    
    '----------------
    '切换打印的标记
    '----------------
    
    Dim i As Integer
    Dim strSQL As String
    
    For i = 1 To Me.SelectedItems.Count
        If bPrint Then
            If Me.TagPrintNumber >= MAX_PRINT_IMAGES Then
                MsgBox "最多只能打印 " & MAX_PRINT_IMAGES & " 幅图片!", vbOKOnly + vbInformation, "提示"
                Exit For
            End If
        End If
        Me.ImageFiles(Me.SelectedItems(i)).TagPrint = bPrint
        If bPrint Then
            strSQL = "UPDATE US_MEDIA SET [PRINT] = '" & 1 & "' WHERE US_NO = '" & frmReport.txtUSNo.Text & "' AND FILE_NAME = '" & Me.ImageFiles(Me.SelectedItems(i)).FileFullName & "'"
        Else
            strSQL = "UPDATE US_MEDIA SET [PRINT] = '" & 0 & "' WHERE US_NO = '" & frmReport.txtUSNo.Text & "' AND FILE_NAME = '" & Me.ImageFiles(Me.SelectedItems(i)).FileFullName & "'"
        End If
        ConnData.Execute strSQL
    Next i
    ShowImage

End Function

Public Function SaveAs() As Boolean
    Dim FileType As String
    
    '----------------------------
    '对选择的单幅图片另存为其它文件
    '使用文件保存对话框
    '----------------------------
    On Error GoTo ErrHandle:
    
    If Me.SelectedItems.Count <> 1 Then
        MsgBox "请只选择一个图片进行本操作", vbOKOnly + vbInformation, "提示"
        Exit Function
    End If
    
    FileType = Right(Me.SelectedImage.FileFullName, Len(Me.SelectedImage.FileFullName) - (InStrRev(Me.SelectedImage.FileFullName, ".")))
    If FileType = "JPG" Then
        cdlSave.Filter = "Pictures (*.jpg)|*.jpg"
    ElseIf FileType = "BMP" Then
        cdlSave.Filter = "Pictures (*.bmp)|*.bmp"
    End If
    cdlSave.ShowSave
    FileCopy Me.SelectedImage.FileFullName, cdlSave.FileName
    'Me.SelectedImage.FileFullName = cdlSave.FileName
    ShowImage
    Exit Function

ErrHandle:
    SaveAs = False
    Exit Function
    
End Function

Public Function SaveToPath() As Boolean
    
    '-----------------------------
    '将所选择的文件统一保存到另外的路径
    '文件的具体名称不换
    '-----------------------------
    On Error GoTo ErrHandle:
    
    Dim strDir As String
    strDir = BrowseFolder(UserControl.hwnd, "将选择的图象文件保存到以下路径:")
    
    '如果不指定路径.则退出过程
    If strDir = vbNullString Then Exit Function
    
    '开始转移文件
    Dim cIF As ImageFile
    Dim i As Long, Index As Long
    Dim strTemp As String
    
    For i = 1 To Me.SelectedItems.Count
        Index = Me.SelectedItems(i)
        strTemp = strDir & "\" & Me.ImageFiles(Index).FileName
        If FSO.FileExists(strTemp) Then FSO.DeleteFile strTemp
        FSO.MoveFile Me.ImageFiles(Index).FileFullName, strTemp
        Me.ImageFiles(Index).FileFullName = strTemp
    Next i
    
    ShowImage
    Exit Function
    
ErrHandle:
    SaveToPath = False
    Exit Function
    
End Function

Public Function UnSelect() As Boolean
    
    '------------------------
    '取消图片选择
    '------------------------
    Set Me.SelectedItems = Nothing
    ShowImage
    
    RaiseEvent SelectChanged
    
End Function

Public Function SelectAll() As Boolean
    
    '----------------------------
    '选择所有图片
    '----------------------------
    
    Dim i As Long
    
    ClearCollection Me.SelectedItems
    
    For i = 1 To Me.ImageFiles.Count
        Me.SelectedItems.Add i
    Next i
    
    ShowImage
    
End Function

Public Function RemoveSelectedImages() As Boolean
    
    '--------------------------
    '从集合中移除所选择的图片
    '记住：要按照索引从大到小删除
    '--------------------------
    Dim i As Long
    Dim iMax As Long, Index As Integer
    
StartRemove:
    iMax = 0
    Index = 0
    With Me.SelectedItems
        For i = 1 To .Count
            If .Item(i) > iMax Then
                iMax = .Item(i)
                Index = i
            End If
        Next i
        If iMax > 0 Then
            Me.ImageFiles.Delete iMax
            .Remove Index
            GoTo StartRemove
        End If
    End With
    
    '清空选择集合
    Set Me.SelectedItems = Nothing
    ShowImage
    
End Function

Public Function DeleteSelectedImageFiles() As Boolean

    '--------------------------
    '从集合中移除所选择的图片
    '记住：要按照索引从大到小删除
    '--------------------------
    Dim i As Long
    Dim iMax As Long, Index As Integer
    
    i = MsgBox("这将把所选择的文件从硬盘上删除，确定吗？", vbQuestion + vbYesNo, "提示")
    If i = vbNo Then Exit Function
    
StartRemove:
    iMax = 0
    Index = 0       '注意Index才是真正的ImageFiles的ID!
    With Me.SelectedItems
        For i = 1 To .Count
            If .Item(i) > iMax Then
                iMax = .Item(i)
                Index = i
            End If
        Next i
        If iMax > 0 Then
            FSO.DeleteFile Me.ImageFiles(iMax).FileFullName, True
            Me.ImageFiles.Delete iMax
            .Remove Index
            GoTo StartRemove
        End If
    End With
    
    '清空选择集合
    Set Me.SelectedItems = Nothing
    ShowImage

End Function

Private Sub barIB_ToolDropDown(ByVal Tool As ActiveToolBars.SSTool, ByVal ScreenX As Single, ByVal ScreenY As Single)
    
    MsgBox Tool.Id
    
End Sub

Private Sub cmdStop_Click()
    
    '------------------------
    '停止加载
    '------------------------
    
    StopLoad = True
    
End Sub

Private Sub imgSound_Click(Index As Integer)
    
    '-------------------
    '播放该图象的声音
    '-------------------
    Screen.MousePointer = vbHourglass
    PlaySound ImageFiles(Index + ScreenImageBase).SoundFile
    Screen.MousePointer = vbNormal
    
End Sub

Private Sub lblFileName_DblClick(Index As Integer)
    
    '---------------------
    '触发事件
    '---------------------
    RaiseEvent ActivateImage(ImageFiles(Index + ScreenImageBase))
    
End Sub

Private Sub lblFileName_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    
    '------------------------
    '鼠标按下事件，如果同时按下
    '了CTRL键,则为多选；
    '否则是单选，清除其它的选择标记
    '------------------------
    
    Dim gIndex As Integer
    
    '找出相对应的在全部集合中的索引
    gIndex = Index + ScreenImageBase
    
    '--------------------------
    '如果是右键，则弹出相应菜单
    '--------------------------
    If Button = vbRightButton Then
        With barIB
            .Tools("ID_Remove").Enabled = AllowDelete
            .Tools("ID_Delete").Enabled = AllowDelete
            .Tools("ID_TagSave").Visible = ShowAttachInfo
            .Tools("ID_SaveToPath").Enabled = AllowDelete
            .Tools("ID_TagPrint").Visible = ShowAttachInfo
            .Tools("ID_TagSound").Visible = ShowAttachInfo
            .Tools("ID_TagNoPrint").Visible = ShowAttachInfo
            .Tools("ID_TagNoSave").Visible = ShowAttachInfo
            .Tools("ID_TagNoSound").Visible = ShowAttachInfo
    
            '根据版本决定功能是否显示
            .Tools("ID_Print").Visible = USV.AllowPrintImage
            .Tools("ID_PrintAll").Visible = USV.AllowPrintImage
            .Tools("ID_TagSound").Visible = USV.AllowAudio
            .Tools("ID_TagNoSound").Visible = USV.AllowAudio
            
            '根据选择的数目决定是否选择
            If Me.SelectedImageFiles.Count <> 1 Then
                .Tools("ID_Edit").Enabled = False
                .Tools("ID_SaveAs").Enabled = False
                .Tools("ID_PrintSingle").Enabled = False
            Else
                .Tools("ID_Edit").Enabled = True
                .Tools("ID_SaveAs").Enabled = True
                .Tools("ID_PrintSingle").Enabled = True
            End If
            
            .Enabled = False
            .Enabled = True
            .PopupMenu "ID_Pop"
            
        End With
    Else
        MouseSelectItem gIndex, Shift
    End If

End Sub

Private Sub picContainer_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    '--------------------------
    '如果是右键，则弹出相应菜单
    '--------------------------
    On Error Resume Next
    
    If Me.ImageFiles.Count = 0 Then
        Exit Sub
    End If
    
    If Button = vbRightButton Then
        With barIB
            .Tools("ID_Remove").Enabled = AllowDelete
            .Tools("ID_Delete").Enabled = AllowDelete
            .Tools("ID_TagSave").Visible = ShowAttachInfo
            .Tools("ID_SaveToPath").Enabled = AllowDelete
            .Tools("ID_TagPrint").Visible = ShowAttachInfo
            .Tools("ID_TagSound").Visible = ShowAttachInfo
            .Tools("ID_TagNoPrint").Visible = ShowAttachInfo
            .Tools("ID_TagNoSave").Visible = ShowAttachInfo
            .Tools("ID_TagNoSound").Visible = ShowAttachInfo
    
            '根据版本决定功能是否显示
            .Tools("ID_Print").Visible = USV.AllowPrintImage
            .Tools("ID_PrintAll").Visible = USV.AllowPrintImage
            .Tools("ID_TagSound").Visible = USV.AllowAudio
            .Tools("ID_TagNoSound").Visible = USV.AllowAudio
            
            '根据选择的数目决定是否选择
            If Me.SelectedImageFiles.Count <> 1 Then