home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD238.psc / UserControl1.ctl < prev   
Encoding:
Text File  |  1999-08-01  |  7.7 KB  |  214 lines

  1. VERSION 5.00
  2. Begin VB.UserControl ScrollControl 
  3.    BackColor       =   &H00000000&
  4.    ClientHeight    =   1725
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   1500
  8.    InvisibleAtRuntime=   -1  'True
  9.    ScaleHeight     =   1725
  10.    ScaleWidth      =   1500
  11.    Begin VB.PictureBox ParentPic 
  12.       AutoRedraw      =   -1  'True
  13.       AutoSize        =   -1  'True
  14.       BorderStyle     =   0  'None
  15.       Height          =   1320
  16.       Left            =   495
  17.       ScaleHeight     =   1320
  18.       ScaleWidth      =   2265
  19.       TabIndex        =   2
  20.       Top             =   1845
  21.       Visible         =   0   'False
  22.       Width           =   2265
  23.    End
  24.    Begin VB.PictureBox Pic 
  25.       AutoRedraw      =   -1  'True
  26.       AutoSize        =   -1  'True
  27.       BorderStyle     =   0  'None
  28.       Height          =   1560
  29.       Left            =   1890
  30.       ScaleHeight     =   1560
  31.       ScaleWidth      =   2145
  32.       TabIndex        =   0
  33.       Top             =   360
  34.       Visible         =   0   'False
  35.       Width           =   2145
  36.    End
  37.    Begin VB.Label Label1 
  38.       Alignment       =   2  'Center
  39.       BackColor       =   &H00000000&
  40.       Caption         =   "Scroll Control"
  41.       BeginProperty Font 
  42.          Name            =   "Tahoma"
  43.          Size            =   8.25
  44.          Charset         =   0
  45.          Weight          =   700
  46.          Underline       =   0   'False
  47.          Italic          =   0   'False
  48.          Strikethrough   =   0   'False
  49.       EndProperty
  50.       ForeColor       =   &H0000FF00&
  51.       Height          =   195
  52.       Left            =   -225
  53.       TabIndex        =   1
  54.       Top             =   0
  55.       Width           =   1935
  56.    End
  57.    Begin VB.Image PrevImage 
  58.       BorderStyle     =   1  'Fixed Single
  59.       Height          =   1305
  60.       Left            =   120
  61.       Stretch         =   -1  'True
  62.       Top             =   270
  63.       Width           =   1245
  64.    End
  65. End
  66. Attribute VB_Name = "ScrollControl"
  67. Attribute VB_GlobalNameSpace = False
  68. Attribute VB_Creatable = True
  69. Attribute VB_PredeclaredId = False
  70. Attribute VB_Exposed = True
  71. '--------------------'
  72. ' The BitBlt Api Call'
  73. '--------------------'
  74. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  75. '---------------------------------'
  76. ' Declare some groups of constants'
  77. '---------------------------------'
  78. Public Enum ScrollDirection 'These Are Used in the Scroll Direction Property
  79.  Right_To_Left = 1
  80.  Left_To_Right = 2
  81.  Bottom_To_Top = 3
  82.  Top_To_Bottom = 4
  83.  BottomRight_To_TopLeft = 5
  84.  TopLeft_To_BottomRight = 6
  85.  TopRight_To_BottomLeft = 7
  86.  BottomLeft_To_TopRight = 8
  87. End Enum
  88. Public Enum BitBlt_dwROP    'The Different BitBlt Types
  89.  Src_And = &H8800C6
  90.  Src_Copy = &HCC0020
  91.  Src_Invert = &H660046
  92.  Src_Paint = &HEE0086
  93.  Src_Erase = &H440328
  94.  Not_Src_Copy = &H330008
  95.  Not_Src_Erase = &H1100A6
  96. End Enum
  97. '--------------------'
  98. 'Dim Some Stuff'
  99. '--------------------'
  100. Dim X As Integer, Y As Integer 'Position Of The Scrolling Image
  101. Dim Back As Integer, Wdth As Integer, Hght As Integer 'Holds Info for The Parents Size
  102. Dim PicWdth As Integer, PicHght As Integer, Direct As Integer ' Holds Info From the Picture to Blt
  103. 'Property Variables:
  104. Dim m_BitBltStyle As Variant
  105. Dim m_Direction As ScrollDirection
  106. Dim ExitIt As Boolean ' Tells The Scrolling When To Stop
  107. 'Default Property Values:
  108. Const m_def_BitBltStyle = &HCC0020
  109. Const m_def_Direction = 1
  110. Public Sub Stop_Scroll() ' Stop Scrolling
  111.  ExitIt = True
  112. End Sub
  113. Public Sub Start_Scroll() 'Start Scrolling
  114.   '---------------------'
  115.   'Get Some Picture Info'
  116.   '---------------------'
  117.   PicWdth = Int(Pic.Width / Screen.TwipsPerPixelX)
  118.   PicHght = Int(Pic.Height / Screen.TwipsPerPixelY)
  119.   Pic.BackColor = UserControl.Parent.BackColor
  120.   ExitIt = False
  121.   On Error GoTo Nd:
  122.   Do 'Start The Loop
  123.    For Back = 0 To PicWdth
  124.     For Y = -PicHght To Hght Step PicHght ' The Y-Blt Pos
  125.      For X = -PicWdth To Wdth Step PicWdth ' The X-Blt Pos
  126.       Wdth = Int(UserControl.Parent.Width / Screen.TwipsPerPixelX) + PicWdth  'Update Parents Width Variable
  127.       Hght = Int(UserControl.Parent.Height / Screen.TwipsPerPixelY) + PicHght 'Update Parents Height Variable
  128.       BltType = m_BitBltStyle
  129.       Select Case m_Direction 'Only Blt To The Correct Direction
  130.        Case 1 ' Right->Left
  131.         BitBlt UserControl.Parent.hDC, X - Back, Y, PicWdth, PicHght, Pic.hDC, 0, 0, BltType
  132.        Case 2 ' Left->Right
  133.         BitBlt UserControl.Parent.hDC, X + Back, Y, PicWdth, PicHght, Pic.hDC, 0, 0, BltType
  134.        Case 3 ' Bottom->Top
  135.         BitBlt UserControl.Parent.hDC, X, Y - Back, PicWdth, PicHght, Pic.hDC, 0, 0, BltType
  136.        Case 4 ' Top->Bottom
  137.         BitBlt UserControl.Parent.hDC, X, Y + Back, PicWdth, PicHght, Pic.hDC, 0, 0, BltType
  138.        Case 5 ' BottomRight->TopLeft
  139.         BitBlt UserControl.Parent.hDC, X - Back, Y - Back, PicWdth, PicHght, Pic.hDC, 0, 0, BltType
  140.        Case 6 ' TopLeft->BottomRight
  141.         BitBlt UserControl.Parent.hDC, X + Back, Y + Back, PicWdth, PicHght, Pic.hDC, 0, 0, BltType
  142.        Case 7 ' TopRight->BottomLeft
  143.         BitBlt UserControl.Parent.hDC, X - Back, Y + Back, PicWdth, PicHght, Pic.hDC, 0, 0, BltType
  144.        Case 8 ' BottomLeft->TopRight
  145.         BitBlt UserControl.Parent.hDC, X + Back, Y - Back, PicWdth, PicHght, Pic.hDC, 0, 0, BltType
  146.       End Select
  147.       DoEvents
  148.      Next X
  149.     Next Y
  150.    If ExitIt = True Then Exit Sub
  151.    Next Back
  152.   Loop Until ExitIt = True
  153. Nd:
  154. End Sub
  155. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  156. 'MemberInfo=23,0,0,1
  157. Public Property Get Direction() As ScrollDirection
  158.     Direction = m_Direction
  159. End Property
  160. Public Property Let Direction(ByVal New_Direction As ScrollDirection)
  161.     m_Direction = New_Direction
  162.     PropertyChanged "Direction"
  163. End Property
  164. 'Initialize Properties for User Control
  165. Private Sub UserControl_InitProperties()
  166.     m_Direction = m_def_Direction
  167.     m_BitBltStyle = m_def_BitBltStyle
  168. End Sub
  169. 'Load property values from storage
  170. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  171.     m_Direction = PropBag.ReadProperty("Direction", m_def_Direction)
  172.     m_BitBltStyle = PropBag.ReadProperty("BitBltStyle", m_def_BitBltStyle)
  173.     Set Picture = PropBag.ReadProperty("Picture", Nothing)
  174. End Sub
  175. Private Sub UserControl_Resize()
  176.  UserControl.Width = 1500
  177.  UserControl.Height = 1740
  178. End Sub
  179. Private Sub UserControl_Terminate()
  180.  ExitIt = True 'Exit The Scrolling Loop
  181. End Sub
  182. 'Write property values to storage
  183. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  184.     Call PropBag.WriteProperty("Direction", m_Direction, m_def_Direction)
  185.     Call PropBag.WriteProperty("BitBltStyle", m_BitBltStyle, m_def_BitBltStyle)
  186.     Call PropBag.WriteProperty("Picture", Picture, Nothing)
  187. End Sub
  188.  
  189. '-------------------------------------'
  190. 'Enables the User To Change Blt Styles'
  191. '  and To Change The Scrolling Image  '
  192. '-------------------------------------'
  193. Public Property Get BitBltStyle() As BitBlt_dwROP
  194. Attribute BitBltStyle.VB_Description = "The dwRop That the BitBlt Api Uses."
  195.     BitBltStyle = m_BitBltStyle
  196. End Property
  197.  
  198. Public Property Let BitBltStyle(ByVal New_BitBltStyle As BitBlt_dwROP)
  199.     m_BitBltStyle = New_BitBltStyle
  200.     PropertyChanged "BitBltStyle"
  201. End Property
  202.  
  203. Public Property Get Picture() As Picture
  204. Attribute Picture.VB_Description = "Returns/sets a graphic to be displayed in a control."
  205.     Set Picture = Pic.Picture
  206.     Set PrevImage = Pic.Picture
  207. End Property
  208.  
  209. Public Property Set Picture(ByVal New_Picture As Picture)
  210.     Set Pic.Picture = New_Picture
  211.     PropertyChanged "Picture"
  212. End Property
  213.  
  214.