imagebrowser.ctl

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

                .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
    End If
    
End Sub

Private Sub picImage_DblClick(Index As Integer)
    
    '---------------------
    '触发事件
    '---------------------
    If AutoEdit Then
        EditImage ImageFiles(Index + ScreenImageBase).FileFullName
    End If
    
    Me.ShowImage
    
    RaiseEvent ActivateImage(ImageFiles(Index + ScreenImageBase))
    
End Sub

Private Sub picImage_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
        picContainer_MouseDown Button, Shift, x, y
    Else
        MouseSelectItem gIndex, Shift
    End If
    
End Sub

Public Sub MouseSelectItem(gIndex As Integer, Shift As Integer)
    
    '---------------------------------
    '当鼠标选择一个文件时触发此事件，一般
    '在PicImage控件或lblFileName控件的左键
    '事件中引用
    '---------------------------------
    Dim i As Integer
    
    With SelectedItems
        If Shift And vbCtrlMask Then
            '同时按下了CTRL键,则已经在集合中时,去除;不在集合中时添加.
            i = InCollection(Me.SelectedItems, gIndex)
            If i > 0 Then
                .Remove i
            Else
                .Add gIndex
            End If
            
        Else
            '单独按下鼠标左键，清空SelectedItems集合
            ClearCollection SelectedItems
            SelectedItems.Add gIndex
        End If
        
    End With
    
    '刷新显示
    ShowImage
    
    '触发选择变化事件
    RaiseEvent SelectChanged
    
    '如果只有一个被选中的图象，则触发单图片选择事件
    If Me.SelectedItems.Count = 1 Then
        RaiseEvent SingleImageSelected(Me.ImageFiles(Me.SelectedItems(1)))
    End If
    
End Sub

Private Sub UserControl_Initialize()
    
    '--------------------------
    '初始化过程
    '--------------------------
    ClearCollection Me.SelectedItems

    If USV.AllowEditImage Then
        barIB.ToolBars("Main").Tools("ID_Pop").Menu.Tools("ID_Edit").Name = "编辑图像(&E)"
    Else
        barIB.ToolBars("Main").Tools("ID_Pop").Menu.Tools("ID_Edit").Name = "浏览全图(&E)"
    End If
    
    barIB.Refresh
    
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    
    '-----------------------------------
    '初始化控件的属性
    '-----------------------------------
    
    ShowInfo = PropBag.ReadProperty("ShowInfo", False)
    ShowAttachInfo = PropBag.ReadProperty("ShowAttachInfo", False)
    ImageBorder = PropBag.ReadProperty("ImageBorder", False)
    AllowDelete = PropBag.ReadProperty("AllowDelete", True)
    AutoEdit = PropBag.ReadProperty("AutoEdit", True)
    
    ThumbHeight = PropBag.ReadProperty("ThumbHeight", 1200)
    ThumbWidth = PropBag.ReadProperty("ThumbWidth", 1600)
    
    picImage(0).width = ThumbWidth
    picImage(0).height = ThumbHeight
    lblFileName(0).width = ThumbWidth
    
End Sub

Private Sub UserControl_Resize()
    
    '-------------------
    '设置控件的位置
    '-------------------
    On Error Resume Next
    
    If ShowInfo Then
        picContainer.Move 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight - lblInfo.height - 15
        lblInfo.Move 0, UserControl.ScaleHeight - lblInfo.height + 15, UserControl.ScaleWidth
    Else
        picContainer.Move 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight
    End If
    
    vsc.Move picContainer.ScaleWidth - vsc.width, 0, vsc.width, picContainer.ScaleHeight
    
    '-------------------------
    '调整各子图片对象的位置
    '-------------------------
    
    Dim i As Integer
    
    '先卸载全部对象
'    For i = picImage().Count - 1 To 1 Step -1
'        Unload picImage(i)
'        Unload lblFileName(i)
'    Next i
       
    
    '计算可以放下几个图片
    With picContainer
        x = Int((.ScaleWidth - vsc.width) / UnitWidth)
        y = Int(.ScaleHeight / UnitHeight)
        PicOnSameScreen = x * y
        PicAllScreen = x * (Int((.ScaleHeight / UnitHeight) + 0.5))
    End With
    
    If x < 1 Then x = 1
    If y < 1 Then y = 1
    
    ShowImage
    
End Sub

Public Sub BrowseFolderImages(FolderName As String, Optional IncludingSubFolder As Boolean = False)
    
    '------------------------
    '浏览某集合下的全部文件
    '------------------------
    
    '先清空集合
    Set ImageFiles = Nothing
    ClearCollection Me.SelectedItems
        
    ScreenImageBase = 0
    Screen.MousePointer = vbHourglass
    
    cmdStop.Visible = True
    StopLoad = False
    FillImageFile FolderName, IncludingSubFolder
    
    cmdStop.Visible = False
    Screen.MousePointer = vbNormal
    
    UserControl_Resize
    ShowImage
    
End Sub

Private Sub FillImageFile(FolderName As String, Optional IncludingSubFolder As Boolean = False)
    
    '--------------------
    '将图片文件填充到集合中
    '--------------------
    
    Dim cFolder As Folder
    Dim SubFolder As Folder
    Dim cFile As File
    
    Set cFolder = FSO.GetFolder(FolderName)
    
    If StopLoad Then Exit Sub
    
    '依次加入
    With cFolder
        '加入该目录下的文件
        ShowMSG "正在加载「" & FolderName & "」目录下的文件..."
        For Each cFile In .Files
            Select Case UCase(Right(cFile.Name, 4))
                Case ".BMP", ".GIF", ".WMF", ".JPG", ".DIB", ".ICO", ".CUR"
                    ImageFiles.Add cFile.Path
                Case Else
            End Select
            DoEvents
        Next cFile
        
        '加入所有子目录的文件(如果有设置)
        If IncludingSubFolder Then
            For Each SubFolder In .SubFolders
                FillImageFile SubFolder.Path, True
            Next SubFolder
        End If
    End With
    
End Sub

Private Sub ShowMSG(strMsg As String)
    
    '显示一个消息
    
    lblInfo.Caption = strMsg
    RaiseEvent message(strMsg)

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    
    PropBag.WriteProperty "ShowInfo", ShowInfo, False
    PropBag.WriteProperty "ShowAttachInfo", ShowAttachInfo, False
    PropBag.WriteProperty "ImageBorder", ImageBorder, False
    PropBag.WriteProperty "AllowDelete", AllowDelete, True
    PropBag.WriteProperty "AutoEdit", AutoEdit, True
    
End Sub

Private Sub vsc_Change()
    ScreenImageBase = vsc.Value * x
    ShowImage
End Sub

Public Property Get ShowAttachInfo() As Boolean
    
    '读取是否显示附加信息
    ShowAttachInfo = m_ShowAttachInfo
    
End Property

Public Property Let ShowAttachInfo(NewValue As Boolean)
    
    '设置是否显示附加信息
    m_ShowAttachInfo = NewValue
    
End Property

Public Property Get ShowInfo() As Boolean
    
    '读取是否显示信息
    ShowInfo = m_ShowInfo

End Property

Public Property Let ShowInfo(NewValue As Boolean)
    
    '设置是否显示图片
    m_ShowInfo = NewValue
    UserControl_Resize

End Property

Public Property Get AllowDelete() As Boolean
    
    '是否允许清除图像
    AllowDelete = m_AllowDelete
    
End Property

Public Property Let AllowDelete(NewValue As Boolean)
    
    '设置是否允许清除图像
    m_AllowDelete = NewValue
    
End Property

Public Property Get AutoEdit() As Boolean
    
    '是否自动编辑图像
    AutoEdit = m_AutoEdit

End Property

Public Property Let AutoEdit(NewValue As Boolean)
    
    '设置是否允许自动编辑图像
    m_AutoEdit = NewValue
    
End Property

Public Property Get ImageBorder() As Boolean
    
    '读取图像是否有边框
    ImageBorder = m_ImageBorder

End Property

Public Property Let ImageBorder(NewValue As Boolean)
    
    '设置图像是否有边框
    Dim i As Integer
    
    m_ImageBorder = NewValue
    For i = 0 To picImage.Count - 1
        picImage(i).BorderStyle = Abs(NewValue)
    Next i
    
End Property

Private Sub vsc_Scroll()
'    vsc_Change
End Sub

Public Sub Clear()
    
    '-------------------
    '清除所有的对象
    '-------------------
    Dim i As Integer
    
    For i = picImage().Count - 1 To 1 Step -1
        picImage(i).Visible = False
        lblFileName(i).Visible = False
        Unload picImage(i)
        Unload lblFileName(i)
        '如果显示附加信息,,则也要清除这些信息的图表
        If ShowAttachInfo Then
            imgSave(i).Visible = False
            imgSound(i).Visible = False
            imgPrint(i).Visible = False
            Unload imgSave(i)
            Unload imgSound(i)
            Unload imgPrint(i)
        End If

    Next i

    Set ImageFiles = Nothing
    ScreenImageBase = 0
    
End Sub

Public Sub ClearCollection(col As Collection)

    '--------------------------
    '清空并重置一个集合
    '--------------------------
    
    Do While col.Count
        col.Remove 1
    Loop
    
End Sub

Public Function InCollection(col As Collection, vItem) As Integer
    
    '---------------------------
    '返回某项目在集合中的位置
    '如果不在集合中，则返回0
    '---------------------------
    
    Dim i As Integer
    
    For i = 1 To col.Count
        If col(i) = vItem Then
            InCollection = i
            Exit Function
        End If
    Next i
    
    InCollection = 0
        
End Function

Public Property Get SelectedImage() As ImageFile
    
    '----------------------------
    '当选择图象为一个时返回该应用
    '----------------------------
    
    With Me.SelectedItems
        If .Count <> 1 Then
            Set SelectedImage = Nothing: Exit Function
        Else
            Set SelectedImage = Me.ImageFiles(Me.SelectedItems(1))
        End If
    End With
        
End Property

Public Property Get TagPrintNumber() As Integer

    '------------------------------
    '返回所选择图象中标记为打印的个数
    '------------------------------
    Dim cIF As ImageFile
    Dim i As Integer
    
    i = 0
    For Each cIF In Me.ImageFiles
        If cIF.TagPrint Then i = i + 1
    Next cIF
    
    TagPrintNumber = i
    
End Property