aspicturebox2.ctl

这是个不错的源程序

VERSION 5.00
Begin VB.UserControl ASPictureBox2 
   AutoRedraw      =   -1  'True
   BackStyle       =   0  '透明
   ClientHeight    =   2535
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4215
   PropertyPages   =   "ASPictureBox2.ctx":0000
   ScaleHeight     =   169
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   281
   ToolboxBitmap   =   "ASPictureBox2.ctx":0010
   Begin VB.VScrollBar vsbScroll 
      Height          =   2295
      Left            =   3960
      TabIndex        =   3
      TabStop         =   0   'False
      Top             =   0
      Visible         =   0   'False
      Width           =   200
   End
   Begin VB.HScrollBar hsbScroll 
      Height          =   200
      Left            =   0
      TabIndex        =   2
      TabStop         =   0   'False
      Top             =   2280
      Visible         =   0   'False
      Width           =   3975
   End
   Begin VB.PictureBox picTwo 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      Height          =   2295
      Left            =   0
      ScaleHeight     =   149
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   261
      TabIndex        =   1
      Top             =   0
      Width           =   3975
   End
   Begin VB.PictureBox picOne 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   495
      Left            =   0
      ScaleHeight     =   33
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   81
      TabIndex        =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   1215
   End
End
Attribute VB_Name = "ASPictureBox2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2007/08/29
'描    述：VB6图像比较分析控件源代码
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************

Option Explicit
Event Click()
Attribute Click.VB_MemberFlags = "200"
Event DblClick()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event ReadProperties(PropBag As PropertyBag)
Event WriteProperties(PropBag As PropertyBag)
Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long

Private Sub hsbScroll_Change()
 UpdatePicTwo
 ShowMasks
End Sub

Public Sub hsbScroll_Scroll()
 hsbScroll_Change
End Sub

Private Sub picOne_Change()
    If picOne.ScaleWidth <= picTwo.ScaleWidth _
       Or picOne.Picture = LoadPicture() _
       Then hsbScroll.Visible = False

    If picOne.ScaleHeight <= picTwo.ScaleHeight _
       Or picOne.Picture = LoadPicture() _
       Then vsbScroll.Visible = False

    If picOne.Picture = LoadPicture() _
       Then picTwo.Picture = LoadPicture()
    Exit Sub

    picTwo.Picture = picOne.Picture

    If picOne.ScaleWidth > picTwo.ScaleWidth Then
        hsbScroll.Visible = True
    End If

    If picOne.ScaleHeight > picTwo.ScaleHeight Then
        vsbScroll.Visible = True
    End If

    Call hsbScrollSett_Refresh
    Call vsbScrollSett_Refresh

End Sub

Private Sub picTwo_Click()
    RaiseEvent Click

End Sub

Private Sub UserControl_Initialize()
 UserControl.ScaleMode = vbPixels
 picOne.ScaleMode = vbPixels
 picTwo.ScaleMode = vbPixels

End Sub

Private Sub UserControl_Resize()

 If UserControl.Height < 1500 Then
  UserControl.Height = 1500
 ElseIf UserControl.Width < 1500 Then
  UserControl.Width = 1500
 End If
'******************
 picTwo.Height = UserControl.ScaleHeight - hsbScroll.Height
 picTwo.Width = UserControl.ScaleWidth - vsbScroll.Width
'************************
 vsbScroll.Left = picTwo.Width
 vsbScroll.Height = picTwo.Height
 hsbScroll.Top = picTwo.Height
 hsbScroll.Width = picTwo.Width

 Call picOne_Change

End Sub

Private Sub vsbScroll_Change()

 UpdatePicTwo
 ShowMasks
 
End Sub

Public Sub vsbScroll_Scroll()
 vsbScroll_Change
End Sub

Private Sub UpdatePicTwo()

 If hsbScroll.Visible = False _
 And vsbScroll.Visible = False Then Exit Sub

 picTwo.PaintPicture picOne.Picture, 0, 0, _
 picTwo.ScaleWidth, picTwo.ScaleHeight, _
 hsbScroll.Value, vsbScroll.Value, _
 picTwo.ScaleWidth, picTwo.ScaleHeight, _
 vbSrcCopy

End Sub

Public Property Get Picture() As Picture
Attribute Picture.VB_Description = "Returns/sets a graphic to be displayed in a control."
Attribute Picture.VB_UserMemId = 0
Attribute Picture.VB_MemberFlags = "200"
    Set Picture = picOne.Picture
End Property

Public Property Let Picture(ByVal New_Picture As IPictureDisp)
    Set Picture = New_Picture
End Property

Public Property Set Picture(ByVal New_Picture As Picture)
 Set picOne.Picture = New_Picture
 PropertyChanged "Picture"
End Property

Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
    BackColor = picTwo.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    picTwo.BackColor() = New_BackColor
    Call UpdatePicTwo
    PropertyChanged "BackColor"
End Property

Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
    BorderStyle = picTwo.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    picTwo.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

Private Sub picTwo_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub picTwo_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub picTwo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub picTwo_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    RaiseEvent ReadProperties(PropBag)

    Set Picture = PropBag.ReadProperty("Picture", Nothing)
    picTwo.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    picTwo.BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    RaiseEvent WriteProperties(PropBag)

    Call PropBag.WriteProperty("Picture", Picture, Nothing)
    Call PropBag.WriteProperty("BackColor", picTwo.BackColor, &H8000000F)
    Call PropBag.WriteProperty("BorderStyle", picTwo.BorderStyle, 1)
End Sub

Private Sub hsbScrollSett_Refresh()
    hsbScroll.Value = 0
    If picOne.ScaleWidth <= picTwo.ScaleWidth Then Exit Sub
    hsbScroll.Max = picOne.ScaleWidth - picTwo.ScaleWidth
    '**************
    If hsbScroll.Max < 25 Then
        hsbScroll.LargeChange = 1
        hsbScroll.SmallChange = 1
    Else
        hsbScroll.LargeChange = hsbScroll.Max \ 10
        hsbScroll.SmallChange = hsbScroll.Max \ 25
    End If

End Sub

Private Sub vsbScrollSett_Refresh()
    vsbScroll.Value = 0
    If picOne.ScaleHeight <= picTwo.ScaleHeight Then Exit Sub
    vsbScroll.Max = picOne.ScaleHeight - picTwo.ScaleHeight
    '****************
    If vsbScroll.Max < 25 Then
        vsbScroll.LargeChange = 1
        vsbScroll.SmallChange = 1
    Else
        vsbScroll.LargeChange = vsbScroll.Max \ 10
        vsbScroll.SmallChange = vsbScroll.Max \ 25
    End If

End Sub

Public Function mPoint(X As Integer, Y As Integer) As Long
    mPoint = picTwo.Point(X, Y)
End Function

Public Function ghdc() As Long
    ghdc = picTwo.hdc
End Function

Public Function DoLine(ix As Single, iy As Single, X As Single, Y As Single)
    picTwo.Line (ix, iy)-(ix, Y), vbGreen
    picTwo.Line -(X, Y), vbGreen
    picTwo.Line -(X, iy), vbGreen
    picTwo.Line -(ix, iy), vbGreen

    Dim sX As Long, sY As Long, isDone As Boolean
    sX = ix
    sY = iy
    Do
        If isDone = False Then
            SetPixelV picTwo.hdc, sX, sY, vbGreen
            isDone = True
        Else
            isDone = False
        End If

        If sX > X Then
            sY = sY + 1
            sX = ix
            If sY > Y Then
                Exit Do
            End If
        Else
            sX = sX + 1
        End If

    Loop

End Function

Public Function VSVal() As Integer
    VSVal = vsbScroll.Value
End Function

Public Function HSVal() As Integer
    HSVal = hsbScroll.Value
End Function

Private Sub ShowMasks()

    Dim tx As Single, ty As Single, tx1 As Single, ty1 As Single
    Dim i As Integer, one$

    If frmMain.lstChild.ListCount > 0 Then

        For i = 0 To frmMain.lstChild.ListCount - 1

            one$ = frmMain.lstChild.List(i)
            tx = Split(one$, ",")(0) - hsbScroll.Value
            ty = Split(one$, ",")(1) - vsbScroll.Value
            tx1 = Split(one$, ",")(2) - hsbScroll.Value
            ty1 = Split(one$, ",")(3) - vsbScroll.Value
            frmMain.aspbChild.DoLine tx, ty, tx1, ty1

        Next i

    End If

End Sub



Public Function PicRefresh()
    picTwo.Cls
End Function