ucpicscroll.ctl

管理电子相片 可以进行上传 评价 浏览 等操作

VERSION 5.00
Begin VB.UserControl ucPicScroll 
   ClientHeight    =   2700
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3180
   ClipControls    =   0   'False
   LockControls    =   -1  'True
   ScaleHeight     =   180
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   212
   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            =   285
      ScaleHeight     =   158
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   150
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   195
      Visible         =   0   'False
      Width           =   2250
   End
   Begin VB.Image cGrab 
      Height          =   480
      Left            =   2670
      Picture         =   "ucPicScroll.ctx":0000
      Top             =   150
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image cRelease 
      Height          =   480
      Left            =   2670
      Picture         =   "ucPicScroll.ctx":030A
      Top             =   630
      Visible         =   0   'False
      Width           =   480
   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
'------------------------------------------------------------------------------

Option Explicit

Private Type tSize
    sWidth  As Single
    sHeight As Single
End Type

'-- Private variables
Private p_HV As Long               ' Horizontal scrolling value
Private p_VV As Long               ' Vertical scrolling value
Private p_HM As Long               ' Horizontal max. scrolling
Private p_VM As Long               ' Vertical max. scrolling value

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

Private p_ZoomFactor(14) As Long
Private p_ZoomIndex      As Long

'-- Property Variables
Private p_Size      As tSize
Private p_MouseIcon As StdPicture

'-- 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_InitProperties()
    BackColor = &H8000000F
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    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("BackColor", PicScroll.BackColor, &H8000000F)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    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 pointer
        If (.Width > ScaleWidth Or .Height > ScaleHeight) Then
            PicScroll.MousePointer = vbCustom
            PicScroll.MouseIcon = cRelease
          Else
            PicScroll.MousePointer = vbDefault
        End If
        
        '-- Show Picture
        .Visible = True
    End With
End Sub

Private Sub UserControl_Terminate()
    Set Picture = Nothing
End Sub

'------------------------------------------------------------------------------
' Properties
'------------------------------------------------------------------------------

'-- 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
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
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
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
    If (Button = vbLeftButton) Then PicScroll.MouseIcon = cGrab

    '-- 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
    PicScroll.MouseIcon = cRelease
    
    RaiseEvent MouseUp(Button, Shift, x, y)
End Sub

'------------------------------------------------------------------------------
' Methods
'------------------------------------------------------------------------------

'-- Clear
Public Sub Clear()
    Set Picture = Nothing
End Sub

'-- BestFit
Public Sub BestFit()

  Dim relW As Single 'Width coef.
  Dim relH As Single 'Height coef.
  Dim W    As Long   'Final Width
  Dim H    As Long   'Final Height
 
    If (Picture = 0) Then Exit Sub

    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

'-- 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
    If (newWidth < p_Size.sWidth Or newHeight < p_Size.sHeight) Then
        SetStretchBltMode PicScroll.hdc, COLORONCOLOR
      Else
        SetStretchBltMode PicScroll.hdc, &H0
    End If
    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
    On Error GoTo 0
    
    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
    
    '-- 100% Default
    p_ZoomIndex = 10
End Sub