ucpicscroll.ctl

几个不错的VB例子

VERSION 5.00
Begin VB.UserControl ucPicScroll 
   ClientHeight    =   2700
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2715
   ClipControls    =   0   'False
   LockControls    =   -1  'True
   ScaleHeight     =   180
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   181
   Begin VB.PictureBox PicScroll 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      ClipControls    =   0   'False
      ForeColor       =   &H80000008&
      Height          =   2355
      Left            =   0
      ScaleHeight     =   157
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   156
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   0
      Width           =   2340
   End
   Begin VB.PictureBox PicLoaded 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ClipControls    =   0   'False
      ForeColor       =   &H80000008&
      Height          =   2370
      Left            =   300
      ScaleHeight     =   158
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   150
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   180
      Visible         =   0   'False
      Width           =   2250
   End
End
Attribute VB_Name = "ucPicScroll"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ===================
' ucPicScroll OCX 1.2
'     C.P.V. 2001
' ===================





Option Explicit

'## Enumerated constants
Enum Appearance
     [Flat]
     [3D]
End Enum

Enum BorderStyle
     [None]
     [Fixed Single]
End Enum

'## Types
Private Type Sizes
             sWidth As Single
             sHeight As Single
End Type

'## Private variables
Private p_HV As Integer             'Horizontal scrolling value
Private p_VV As Integer             'Vertical scrolling value
Private p_HM As Integer             'Horizontal max. scrolling
Private p_VM As Integer             'Vertical max. scrolling value

Private p_PictureMoving As Boolean  'Scrolling flag
Private p_ancPos As POINTAPI        'Anchor point
Private p_tmpPos As POINTAPI        'Temporary point

Private p_ZoomFactor(0 To 14) As Integer
Private p_ZoomIndex As Integer

'## Property Variables
Private p_Size As Sizes
Private p_MouseIcon

'## Event Declarations
Public Event Click()
Public Event DblClick()
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)


' =================================================================================
' Init, Read, Write properties
' =================================================================================

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    UserControl.Appearance = PropBag.ReadProperty("Appearance", 1)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    
    PicScroll.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    Set Picture = PropBag.ReadProperty("Picture", Nothing)

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Appearance", UserControl.Appearance, 1)
    Call PropBag.WriteProperty("BackColor", PicScroll.BackColor, &H8000000F)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 0)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("Picture", Picture, Nothing)

End Sub

' =================================================================================
' User control
' =================================================================================

Private Sub UserControl_Initialize()

    ReadZoomFactors
    
End Sub

Private Sub UserControl_Show()

    UserControl_Resize
    
End Sub

Private Sub UserControl_Resize()

    With PicScroll
    
        '## Set max values
        p_HM = IIf(Picture <> 0, .ScaleWidth - ScaleWidth, 0)
        p_VM = IIf(Picture <> 0, .ScaleHeight - ScaleHeight, 0)
        
        '## Center picture
        If Picture <> 0 Then
            p_HV = p_HM / 2
            p_VV = p_VM / 2
            .Move -p_HV, -p_VV
        Else
            .Width = ScaleWidth
            .Height = ScaleHeight
        End If
        
        '## Set MousePointer
        If .Width > ScaleWidth And _
           .Height < ScaleHeight Then
               .MousePointer = vbSizeWE
        ElseIf .Height > ScaleHeight And _
               .Width < ScaleWidth Then
               .MousePointer = vbSizeNS
        ElseIf .Width > ScaleWidth And _
               .Height > ScaleHeight Then
               .MousePointer = vbSizeAll
        Else
               .MousePointer = vbDefault
        End If
        
        '## Show Picture
        .Visible = True
        
    End With
    
End Sub

Private Sub UserControl_Terminate()

    Set Picture = Nothing
    
End Sub

' =================================================================================
' Properties
' =================================================================================

'# #Appearance
Public Property Get Appearance() As Appearance

    Appearance = UserControl.Appearance
    
End Property

Public Property Let Appearance(ByVal New_Appearance As Appearance)

    UserControl.Appearance() = New_Appearance
    PicScroll.BackColor = BackColor
    PropertyChanged "Appearance"
    
End Property

'## BackColor
Public Property Get BackColor() As OLE_COLOR

    BackColor = UserControl.BackColor
    
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)

    UserControl.BackColor = New_BackColor
    PicScroll.BackColor = New_BackColor
    PicLoaded.BackColor = New_BackColor
    PropertyChanged "BackColor"
    
End Property

'## BorderStyle
Public Property Get BorderStyle() As BorderStyle

    BorderStyle = UserControl.BorderStyle
    
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As BorderStyle)

    UserControl.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
    
End Property

'## Enabled
Public Property Get Enabled() As Boolean

    Enabled = UserControl.Enabled
    
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)

    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"
    
End Property

'## Picture
Public Property Get Picture() As StdPicture
Attribute Picture.VB_UserMemId = 0

    Set Picture = PicScroll
    
End Property

Public Property Set Picture(ByVal New_Picture As StdPicture)

    '## Hide picscroll (Showed in resize event)
    PicScroll.Visible = False
    
    '## Set picture and temp picture
    Set PicScroll = New_Picture
    Set PicLoaded = New_Picture
    
    '## Get original size
    p_Size.sWidth = PicScroll.Width
    p_Size.sHeight = PicScroll.Height
    
    '## Center picture and set scroll values
    UserControl_Resize
    
    PropertyChanged "Picture"
    
End Property

'## ZoomPercent
Public Property Get ZoomPercent()

    ZoomPercent = p_ZoomFactor(p_ZoomIndex)
    
End Property

' =================================================================================
' Events
' =================================================================================

Private Sub PicScroll_Click()

    RaiseEvent Click
    
End Sub

Private Sub PicScroll_DblClick()

    RaiseEvent DblClick
    
End Sub

Private Sub PicScroll_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    p_PictureMoving = True
    
    '## Get "anchor" point
    GetCursorPos p_ancPos
    p_tmpPos.x = p_ancPos.x
    p_tmpPos.y = p_ancPos.y
    
    RaiseEvent MouseDown(Button, Shift, x, y)
    
End Sub

Private Sub PicScroll_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    '## Check button...
    If Button <> vbLeftButton Or _
       Picture = 0 Or _
       p_PictureMoving = False Then Exit Sub
       
    '## Get cursor position
    GetCursorPos p_ancPos
    
    '## Horizontal scrolling
    If PicScroll.ScaleWidth > ScaleWidth Then
        If (p_ancPos.x - p_tmpPos.x) > 0 Then
            If p_HV - (p_ancPos.x - p_tmpPos.x) > 0 Then
                p_HV = p_HV - (p_ancPos.x - p_tmpPos.x)
            Else
                p_HV = 0
            End If
        Else
            If p_HV - (p_ancPos.x - p_tmpPos.x) < p_HM Then
                p_HV = p_HV - (p_ancPos.x - p_tmpPos.x)
            Else
                p_HV = p_HM
            End If
        End If
    End If
    
    '## Vertical scrolling
    If PicScroll.ScaleHeight > ScaleHeight Then
        If (p_ancPos.y - p_tmpPos.y) > 0 Then
            If p_VV - (p_ancPos.y - p_tmpPos.y) > 0 Then
                p_VV = p_VV - (p_ancPos.y - p_tmpPos.y)
            Else
                p_VV = 0
            End If
        Else
            If p_VV - (p_ancPos.y - p_tmpPos.y) < p_VM Then
                p_VV = p_VV - (p_ancPos.y - p_tmpPos.y)
            Else
                p_VV = p_VM
            End If
        End If
    End If
    
    '## Set temp cursor position
    p_tmpPos.x = p_ancPos.x
    p_tmpPos.y = p_ancPos.y
    
    '## Move picture
    PicScroll.Move -p_HV, -p_VV
    
    RaiseEvent MouseMove(Button, Shift, x, y)
    
End Sub

Private Sub PicScroll_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    p_PictureMoving = False
    
    RaiseEvent MouseUp(Button, Shift, x, y)
    
End Sub

' =================================================================================
' Methods
' =================================================================================

'## Clear
Public Sub Clear()

    Set Picture = Nothing
    
End Sub

'## BestFit
Public Sub BestFit()

    If Picture = 0 Then Exit Sub
    
    Dim relW As Single  'Width coef.
    Dim relH As Single  'Height coef.
    
    Dim W As Integer    'Final Width
    Dim H As Integer    'Final Height
    
    If (p_Size.sHeight <> ScaleHeight) Or (p_Size.sWidth <> ScaleWidth) Then
    
        relH = ScaleHeight / p_Size.sHeight
        relW = ScaleWidth / p_Size.sWidth
        
        If relW < relH Then
           W = ScaleWidth
           H = Int(p_Size.sHeight * relW)
        Else
           H = ScaleHeight
           W = Int(p_Size.sWidth * relH)
        End If
        
    Else
    
        W = p_Size.sWidth
        H = p_Size.sHeight
        
    End If
    
    PictureSize W, H

End Sub

'## Stretch
Public Sub Stretch()
     
    If Picture = 0 Then Exit Sub
    
    PictureSize ScaleWidth, ScaleHeight
     
End Sub

'## ZoomIn
Public Sub ZoomIn()

    If Picture = 0 Then Exit Sub
    
    If p_ZoomIndex < 14 Then
        p_ZoomIndex = p_ZoomIndex + 1
        PictureSize p_Size.sWidth * p_ZoomFactor(p_ZoomIndex) / 100, p_Size.sHeight * p_ZoomFactor(p_ZoomIndex) / 100
    End If
    
End Sub

'## ZoomOut
Public Sub ZoomOut()

    If Picture = 0 Then Exit Sub
    
    If p_ZoomIndex > 0 Then
        p_ZoomIndex = p_ZoomIndex - 1
        PictureSize p_Size.sWidth * p_ZoomFactor(p_ZoomIndex) / 100, p_Size.sHeight * p_ZoomFactor(p_ZoomIndex) / 100
    End If
    
End Sub

'## ZoomPrevious
Public Sub ZoomPrevious()

    If Picture = 0 Then Exit Sub
    
    PictureSize p_Size.sWidth * p_ZoomFactor(p_ZoomIndex) / 100, p_Size.sHeight * p_ZoomFactor(p_ZoomIndex) / 100
    
End Sub

'## ZoomReal
Public Sub ZoomReal()

    If Picture = 0 Then Exit Sub
    '# 100%
    p_ZoomIndex = 10
    PictureSize p_Size.sWidth, p_Size.sHeight
    
End Sub

' =================================================================================
' Private Subs
' =================================================================================

'## PictureSize
Private Sub PictureSize(ByVal newWidth As Integer, ByVal newHeight As Integer)
    
    Screen.MousePointer = vbHourglass
    PicScroll.Visible = False
    
        PicScroll.Width = newWidth
        PicScroll.Height = newHeight
       
        On Error Resume Next
        StretchBlt PicScroll.hdc, _
                   0, 0, _
                   newWidth, newHeight, _
                   PicLoaded.hdc, _
                   0, 0, _
                   p_Size.sWidth, p_Size.sHeight, _
                   SRCCOPY
                       
        If Err.Number > 0 Then
            Err.Clear
            ZoomReal
        End If
    
    UserControl_Resize
    Screen.MousePointer = vbDefault

End Sub

'## ReadZoomFactors
Private Sub ReadZoomFactors()
    
    p_ZoomFactor(0) = 5
    p_ZoomFactor(1) = 10
    p_ZoomFactor(2) = 20
    p_ZoomFactor(3) = 30
    p_ZoomFactor(4) = 40
    p_ZoomFactor(5) = 50
    p_ZoomFactor(6) = 60
    p_ZoomFactor(7) = 70
    p_ZoomFactor(8) = 80
    p_ZoomFactor(9) = 90
    p_ZoomFactor(10) = 100
    p_ZoomFactor(11) = 125
    p_ZoomFactor(12) = 150
    p_ZoomFactor(13) = 175
    p_ZoomFactor(14) = 200
    
    p_ZoomIndex = 10  '100% Default
    
End Sub