scroller.ctl

vb串口程序

VERSION 5.00
Begin VB.UserControl Scroller 
   ClientHeight    =   3645
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ControlContainer=   -1  'True
   PropertyPages   =   "Scroller.ctx":0000
   ScaleHeight     =   3645
   ScaleWidth      =   4800
   ToolboxBitmap   =   "Scroller.ctx":0013
   Begin VB.PictureBox LineBottom 
      Appearance      =   0  'Flat
      BackColor       =   &H00E0E0E0&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   135
      Left            =   60
      ScaleHeight     =   135
      ScaleWidth      =   1935
      TabIndex        =   4
      Top             =   720
      Width           =   1935
   End
   Begin VB.PictureBox LineRight 
      Appearance      =   0  'Flat
      BackColor       =   &H00E0E0E0&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   135
      Left            =   60
      ScaleHeight     =   135
      ScaleWidth      =   1935
      TabIndex        =   3
      Top             =   480
      Width           =   1935
   End
   Begin VB.PictureBox LineLeft 
      Appearance      =   0  'Flat
      BackColor       =   &H00808080&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   135
      Left            =   60
      ScaleHeight     =   135
      ScaleWidth      =   1935
      TabIndex        =   2
      Top             =   300
      Width           =   1935
   End
   Begin VB.PictureBox LineTop 
      Appearance      =   0  'Flat
      BackColor       =   &H00808080&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   135
      Left            =   60
      ScaleHeight     =   135
      ScaleWidth      =   1935
      TabIndex        =   1
      Top             =   60
      Width           =   1935
   End
   Begin VB.PictureBox pctPos 
      Appearance      =   0  'Flat
      BackColor       =   &H00404040&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   3615
      Left            =   2040
      ScaleHeight     =   3615
      ScaleWidth      =   1305
      TabIndex        =   0
      Top             =   0
      Width           =   1305
      Begin VB.Shape ShpPos 
         BackColor       =   &H00808080&
         BackStyle       =   1  'Opaque
         BorderStyle     =   0  'Transparent
         Height          =   1815
         Left            =   60
         Top             =   0
         Width           =   135
      End
   End
   Begin VB.Label lblArea 
      BackStyle       =   0  'Transparent
      Height          =   2055
      Left            =   60
      MouseIcon       =   "Scroller.ctx":0325
      MousePointer    =   99  'Custom
      TabIndex        =   5
      Top             =   1020
      Width           =   1695
   End
End
Attribute VB_Name = "Scroller"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
'********************* SCROLLER CONTROL ********************
'Created by Tincani Andrea                                  26-4-1999
'Ver 1.0.0
'__________________________________________________________
'Find more FREE Source Code at
'http://pages.hotbot.com/edu/tincani.andrea/index.html

'Feel free to mail at [e-mail] for any explanation, question
'or bug report about this control...

Option Explicit

Dim ypos As Single
Dim CurrPos As Single
Dim MaxPos As Single

Private Sub lblArea_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
    If Button = vbLeftButton Then
        ypos = Y
    End If
End Sub

Private Sub lblArea_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    Dim ctr As Control
    Dim oldPos As Single

    If Button = vbLeftButton Then
        oldPos = CurrPos
        If ypos < 0 Then ypos = Y
        If Abs(ypos - Y) >= Screen.TwipsPerPixelY Then
            For Each ctr In UserControl.ContainedControls
                If Not ctr Is lblArea Then
                    If CurrPos - ypos + Y <= 0 And CurrPos - ypos + Y >= UserControl.ScaleHeight - MaxPos Then
                        ctr.Move ctr.Left, ctr.Top - ypos + Y
                    Else
                        If CurrPos - ypos + Y > 0 Then
                            ctr.Move ctr.Left, ctr.Top - CurrPos
                        Else
                            ctr.Move ctr.Left, ctr.Top + UserControl.ScaleHeight - MaxPos - CurrPos
                        End If
                    End If
                End If
            Next
            CurrPos = CurrPos - ypos + Y
            If CurrPos > 0 Then CurrPos = 0
            If CurrPos < UserControl.ScaleHeight - MaxPos Then CurrPos = UserControl.ScaleHeight - MaxPos
            ypos = Y
            If oldPos <> CurrPos Then SetScrollPosition
        End If
    End If
End Sub

Private Sub lblArea_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    ypos = -1
End Sub

Private Sub UserControl_Resize()
    Dim x As Control
    
    'Set the lblArea posirtion
    lblArea.Move 0, 0, UserControl.Width, UserControl.Height
    'Set the Scroll Bar Position
    pctPos.Width = Screen.TwipsPerPixelX * 3
    pctPos.Left = UserControl.ScaleWidth - pctPos.Width
    pctPos.Top = 0
    pctPos.Height = UserControl.ScaleHeight
    'Set The Border Lines Position
    LineTop.Move 0, 0, UserControl.ScaleWidth - pctPos.Width - Screen.TwipsPerPixelX, Screen.TwipsPerPixelY
    LineLeft.Move 0, 0, Screen.TwipsPerPixelX, UserControl.ScaleHeight
    LineRight.Move UserControl.ScaleWidth - pctPos.Width - Screen.TwipsPerPixelX, 0, Screen.TwipsPerPixelX, UserControl.ScaleHeight
    LineBottom.Move 0, UserControl.ScaleHeight - Screen.TwipsPerPixelY, UserControl.ScaleWidth - pctPos.Width - Screen.TwipsPerPixelX, Screen.TwipsPerPixelY
    SetScrollPosition
End Sub

Private Sub UserControl_Show()
    Dim MinPos As Single
    Dim x As Control

    CurrPos = 0
    MinPos = UserControl.Height
    For Each x In UserControl.ContainedControls
        If x.Top < MinPos Then MinPos = x.Top
    Next
    For Each x In UserControl.ContainedControls
        x.Top = x.Top - MinPos + Screen.TwipsPerPixelY * 4
    Next
    SetScrollPosition
End Sub

Private Sub SetScrollPosition()
    Dim x As Control

    pctPos.ZOrder 0
    LineTop.ZOrder 0
    LineLeft.ZOrder 0
    LineRight.ZOrder 0
    LineBottom.ZOrder 0
    For Each x In UserControl.ContainedControls
        If Not x Is lblArea Then
            If x.Visible Then
                If x.Top + x.Height - CurrPos + Screen.TwipsPerPixelY * 4 > MaxPos Then MaxPos = x.Top + x.Height - CurrPos + Screen.TwipsPerPixelY * 4
            End If
        End If
    Next
    If MaxPos < UserControl.ScaleHeight Then MaxPos = UserControl.ScaleHeight
    ShpPos.Move 0, (-CurrPos * UserControl.ScaleHeight) \ MaxPos, Screen.TwipsPerPixelX * 4, (UserControl.ScaleHeight * UserControl.ScaleHeight) \ MaxPos + Screen.TwipsPerPixelY
End Sub

'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Restituisce o imposta il colore di sfondo utilizzato per la visualizzazione di testo e grafica in un oggetto."
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
End Sub

Public Sub MoveControls(valore As Long)
    Dim x As Control

    If Ambient.UserMode Then Exit Sub
    'Enabled only at design time to move the contained controls
    For Each x In UserControl.ContainedControls
        If Not x Is lblArea Then
            x.Top = x.Top + valore
        End If
    Next
End Sub