├── .gitattributes ├── .gitignore ├── LICENSE.md ├── README.md ├── ScrollableContainer_Test_OCX.vbg ├── ScrollableContainer_Test_OCX_Readme.txt ├── ScrollableContainer_Test_Source.vbg ├── control-source ├── Help ScrollableContainer control.txt ├── ScrollableContainer.vbp ├── VisualStyleManifest.res ├── cScrollBars.cls ├── cmp │ └── ScllCnt1.cmp ├── ctlScrollableContainer.ctl ├── ctlScrollableContainer.ctx ├── ptpScrollableContainer.pag └── subclass │ ├── cIBSSubclass.cls │ ├── mBSPropsDB.bas │ └── mBSSubclass.bas ├── ocx ├── ScllCnt1 Register (run as Admin).bat ├── ScllCnt1 Unregister (run as Admin).bat └── ScllCnt1.ocx ├── test compiled ocx ├── Form1.frm └── Test_ScrollableContainer.vbp └── test in source code ├── Form1.frm └── Test_ScrollableContainer.vbp /.gitattributes: -------------------------------------------------------------------------------- 1 | * binary 2 | 3 | *.bas working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 4 | *.cls working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 5 | *.ctl working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 6 | *.dob working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 7 | *.dsr working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 8 | *.frm working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 9 | *.pag working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 10 | *.vbg working-tree-encoding=CP1252 text eol=crlf 11 | *.vbl working-tree-encoding=CP1252 text eol=crlf 12 | *.vbp working-tree-encoding=CP1252 text eol=crlf 13 | *.vbr working-tree-encoding=CP1252 text eol=crlf 14 | 15 | *.asm text 16 | *.asp text 17 | *.bat text 18 | *.c text 19 | *.cpp text 20 | *.dsp text 21 | *.dsw text 22 | *.h text 23 | *.idl text 24 | *.java text 25 | *.js text 26 | *.manifest text 27 | *.odl text 28 | *.php text 29 | *.php3 text 30 | *.rc text 31 | *.sln text 32 | *.sql text 33 | *.vb text 34 | *.vbs text 35 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *.oca 3 | *.lib 4 | *.exp 5 | *.log -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2024 EduardoVB 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ScrollableContainer 2 | ScrollableContainer for VB6: a container (like a PictureBox) with scroll capability 3 | [For more information please go to vbForums thread](https://www.vbforums.com/showthread.php?876529-VB6-ScrollableContainer-a-container-(like-a-PictureBox)-with-scroll-capability) 4 | 5 | ![imagen](https://user-images.githubusercontent.com/42319299/175790188-a9c25a34-b771-49f1-8864-1cd27c75ea2a.png) 6 | 7 | [Download the OCX file.](https://github.com/EduardoVB/ScrollableContainer/raw/main/control-bin/ScllCnt1.ocx) 8 | -------------------------------------------------------------------------------- /ScrollableContainer_Test_OCX.vbg: -------------------------------------------------------------------------------- 1 | VBGROUP 5.0 2 | StartupProject=test compiled ocx\Test_ScrollableContainer.vbp 3 | -------------------------------------------------------------------------------- /ScrollableContainer_Test_OCX_Readme.txt: -------------------------------------------------------------------------------- 1 | Run the file: 2 | 3 | Register (run as Admin).bat 4 | 5 | that is in the 'control-bin' folder to be able to use the OCX -------------------------------------------------------------------------------- /ScrollableContainer_Test_Source.vbg: -------------------------------------------------------------------------------- 1 | VBGROUP 5.0 2 | Project=control-source\ScrollableContainer.vbp 3 | StartupProject=test in source code\Test_ScrollableContainer.vbp 4 | -------------------------------------------------------------------------------- /control-source/Help ScrollableContainer control.txt: -------------------------------------------------------------------------------- 1 | Introduction: 2 | 3 | The ScrollableContainer is a container that can have a virtual space larger than the actual physical space. 4 | It can hold controls in a space bigger than its actual height and width. 5 | To add controls at design time, drag the controls inside it as it is done with any other container. 6 | The properties VirtualHeight and VirtualWidth determine the size of the virtual space at design time, and the properties VScrollValue and HScrollValue the scroll position. 7 | Alternatively, you can right click on the control and select "Edit", and the scroll bars will become active at design time. Every time that you add a new control you'll have to select "Edit" again. 8 | 9 | 10 | Reference: 11 | 12 | Properties: 13 | Note: the extender's properties are not included here (Top, Left, Visible, Etc.) 14 | 15 | Notation: 16 | D: available at design time 17 | R: read only property 18 | 19 | AddingControls: -- 20 | AutoScrollOnFocus: D- 21 | BackColor: D- 22 | BorderColor: D- 23 | BorderStyle: D- 24 | BottomFreeSpace: D- 25 | HScrollBar: D- 26 | HScrollMax: -R 27 | HScrollValue: D- 28 | hWnd: -R 29 | RightFreeSpace: D- 30 | VirtualHeight: D(not persistable)- 31 | VirtualWidth: D(not persistable)- 32 | VScrollBar: D- 33 | VScrollMax: -R 34 | VScrollValue: D- 35 | TopScrollBound D- 36 | 37 | Description: 38 | 39 | AddingControls: 40 | Use this property when you need to add controls to this container at run time. It is to indicate to the ScrollableContainer that you are adding controls, so that the position that you set to the newly added controls (Left and Top) are set correctly in the virtual space of the container. 41 | Example use: 42 | 43 | ScrollableContainer1.AddingControls = True 44 | 45 | ' Adding a command button 46 | Set NewCmd1 = Me.Controls.Add("VB.CommandButton", "NewCommand1") 47 | Set NewCmd1.Container = ScrollableContainer1 48 | NewCmd1.Move 1000, 1000 49 | NewCmd1.Caption = "New command 1" 50 | NewCmd1.Visible = True 51 | 52 | ' Adding another command button 53 | Set NewCmd2 = Me.Controls.Add("VB.CommandButton", "NewCommand2") 54 | Set NewCmd2.Container = ScrollableContainer1 55 | NewCmd2.Move 1600, 1000 56 | NewCmd2.Caption = "New command 2" 57 | NewCmd2.Visible = True 58 | 59 | ScrollableContainer1.AddingControls = False 60 | 61 | 62 | AutoScrollOnFocus: 63 | Returns or sets a value that determines if when a contained control gets the focus, if the ScrollableContainer will automatically scroll to show the control in case that it is out of the view. 64 | A control that is out of view can get the focus because the user is navigating with the Tab key, or pressed an accelerator that is set on the control, or there is a SetFocus to that control in the code. 65 | 66 | BackColor: 67 | Returns or sets the background color. 68 | 69 | BorderColor: 70 | Returns or sets the color of the border when BorderStyle is set to efnFlat1Pix or efnFlat2Pix. 71 | 72 | BorderStyle: 73 | Returns or sets a value that determines how the border of the control looks like. 74 | 75 | BottomFreeSpace, RightFreeSpace: 76 | Returns or sets a value that determines, in scale mode units of the ScrollableContainer's container, the free space that will be left at the bottom or the right of the virtual space (when there is no other control to scroll for). 77 | 78 | HScrollBar, VScrollBar: 79 | Returns or sets a value that determines the horizontal or vertical scrollbar visibility at run time. 80 | 81 | HScrollMax, VScrollMax: 82 | Returns a value, in scale mode units of the ScrollableContainer's container, that indicates the maximum value that HScrollValue / VScrollValue can take, corresponding to the scroll bar position's when the scroll box is in its bottom or rightmost position. 83 | 84 | HScrollValue, VScrollValue: 85 | Returns or sets a value, in scale mode units of the ScrollableContainer's container, that indicates the scroll actual position. 86 | It can be set at design time to change the scroll position, but the design time value is not saved and at run time it starts with 0 (zero). 87 | 88 | hWnd: 89 | Returns the Windows handle of the control. 90 | 91 | VirtualHeight, VirtualWidth: 92 | Returns or sets a value that determines, in scale mode units of the ScrollableContainer's container, the height / width of the virtual space where the controls are located. 93 | It can be set at design time to change the virtual space height, but the design time value is not saved and the run time value is calculated automatically. 94 | 95 | TopScrollBound: 96 | Returns or sets a value, in scale mode units of the ScrollableContainer's container, that sets a limit for the Vertical Scroll that the user can set. 97 | 98 | 99 | Events: 100 | 101 | HScrollChange, VScrollChange: 102 | Generated when HScrollValue and VScrollValue change. 103 | 104 | 105 | Methods: 106 | 107 | EnsureControlVisible: 108 | Ensures that the control referenced in the nControl parameter is visible on the container. If it is not, the ScrollableContainer is automatically scrolled in any needed direction to show the control. 109 | Example use: ScrollableContainer1.EnsureControlVisible Text10 110 | 111 | Update: 112 | Updates the virtual space dimensions. Usually not neccesary to call it because it is done automatically. 113 | -------------------------------------------------------------------------------- /control-source/ScrollableContainer.vbp: -------------------------------------------------------------------------------- 1 | Type=Control 2 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\SysWow64\stdole2.tlb#OLE Automation 3 | UserControl=ctlScrollableContainer.ctl 4 | PropertyPage=ptpScrollableContainer.pag 5 | Class=cScrollBars; cScrollBars.cls 6 | Module=mBSPropsDB; subclass\mBSPropsDB.bas 7 | Module=mBSSubclass; subclass\mBSSubclass.bas 8 | Class=IBSSubclass; subclass\cIBSSubclass.cls 9 | ResFile32="VisualStyleManifest.res" 10 | Startup="(None)" 11 | HelpFile="" 12 | Title="Scrollable Container" 13 | ExeName32="ScllCnt1.ocx" 14 | Path32="..\control-bin" 15 | Command32="" 16 | Name="ScllContainer" 17 | HelpContextID="0" 18 | Description="Scrollable Container" 19 | CompatibleMode="0" 20 | CompatibleEXE32="cmp\ScllCnt1.cmp" 21 | MajorVer=1 22 | MinorVer=0 23 | RevisionVer=5 24 | AutoIncrementVer=1 25 | ServerSupportFiles=0 26 | CompilationType=0 27 | OptimizationType=0 28 | FavorPentiumPro(tm)=0 29 | CodeViewDebugInfo=0 30 | NoAliasing=0 31 | BoundsCheck=0 32 | OverflowCheck=0 33 | FlPointCheck=0 34 | FDIVCheck=0 35 | UnroundedFP=0 36 | StartMode=1 37 | Unattended=0 38 | Retained=0 39 | ThreadPerObject=0 40 | MaxNumberOfThreads=1 41 | -------------------------------------------------------------------------------- /control-source/VisualStyleManifest.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ScrollableContainer/7e3f80a3171e11940aa9b1ee6f273d6884902a75/control-source/VisualStyleManifest.res -------------------------------------------------------------------------------- /control-source/cScrollBars.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ScrollableContainer/7e3f80a3171e11940aa9b1ee6f273d6884902a75/control-source/cScrollBars.cls -------------------------------------------------------------------------------- /control-source/cmp/ScllCnt1.cmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ScrollableContainer/7e3f80a3171e11940aa9b1ee6f273d6884902a75/control-source/cmp/ScllCnt1.cmp -------------------------------------------------------------------------------- /control-source/ctlScrollableContainer.ctl: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.UserControl ScrollableContainer 3 | Alignable = -1 'True 4 | Appearance = 0 'Flat 5 | AutoRedraw = -1 'True 6 | BorderStyle = 1 'Fixed Single 7 | ClientHeight = 3600 8 | ClientLeft = 0 9 | ClientTop = 0 10 | ClientWidth = 4800 11 | ControlContainer= -1 'True 12 | EditAtDesignTime= -1 'True 13 | ForwardFocus = -1 'True 14 | PropertyPages = "ctlScrollableContainer.ctx":0000 15 | ScaleHeight = 3600 16 | ScaleWidth = 4800 17 | ToolboxBitmap = "ctlScrollableContainer.ctx":002D 18 | Begin VB.Timer tmrVScrollValue 19 | Enabled = 0 'False 20 | Interval = 1 21 | Left = 2448 22 | Top = 3072 23 | End 24 | Begin VB.Timer tmrHScrollInit 25 | Enabled = 0 'False 26 | Interval = 1 27 | Left = 2060 28 | Top = 3072 29 | End 30 | Begin VB.Timer tmrVScrollInit 31 | Enabled = 0 'False 32 | Interval = 1 33 | Left = 1680 34 | Top = 3072 35 | End 36 | Begin VB.Timer tmrCheckFocus 37 | Enabled = 0 'False 38 | Interval = 500 39 | Left = 1296 40 | Top = 3072 41 | End 42 | Begin VB.Timer tmrMoveLeft 43 | Enabled = 0 'False 44 | Interval = 1 45 | Left = 504 46 | Top = 3072 47 | End 48 | Begin VB.Timer tmrDontIncreaseMax 49 | Enabled = 0 'False 50 | Interval = 1000 51 | Left = 900 52 | Top = 3072 53 | End 54 | Begin VB.Timer tmrMoveTop 55 | Enabled = 0 'False 56 | Interval = 1 57 | Left = 108 58 | Top = 3060 59 | End 60 | End 61 | Attribute VB_Name = "ScrollableContainer" 62 | Attribute VB_GlobalNameSpace = False 63 | Attribute VB_Creatable = True 64 | Attribute VB_PredeclaredId = False 65 | Attribute VB_Exposed = True 66 | Option Explicit 67 | 68 | Implements IBSSubclass 69 | 70 | Private Const SM_CXVSCROLL As Long = 2 71 | Private Const SM_CYHSCROLL As Long = 3 72 | 73 | Private Type RECT 74 | Left As Long 75 | Top As Long 76 | Right As Long 77 | Bottom As Long 78 | End Type 79 | 80 | Private Const WM_SETREDRAW As Long = &HB& 81 | ' Redraw window: 82 | Private Const RDW_ALLCHILDREN = &H80 83 | Private Const RDW_ERASE = &H4 84 | Private Const RDW_INTERNALPAINT = &H2 85 | Private Const RDW_INVALIDATE = &H1 86 | Private Const RDW_UPDATENOW = &H100 87 | 88 | Private Declare Function RedrawWindow Lib "user32" (ByVal hWnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long 89 | Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 90 | Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long 91 | Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long 92 | Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long 93 | Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long 94 | Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long 95 | Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long 96 | Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long 97 | Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 98 | Private Declare Function GetFocus Lib "user32" () As Long 99 | Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long 100 | Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long 101 | Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal Edge As Long, ByVal grfFlags As Long) As Long 102 | 103 | Private Const HWND_NOTOPMOST = -2 104 | Private Const SWP_NOSIZE As Long = &H1 105 | Private Const SWP_NOACTIVATE = &H10& 106 | Private Const SWP_NOMOVE As Long = &H2 107 | Private Const SWP_NOZORDER = &H4 108 | Private Const SWP_FRAMECHANGED = &H20 109 | 110 | Private Const BF_Left = &H1 111 | Private Const BF_TOP = &H2 112 | Private Const BF_Right = &H4 113 | Private Const BF_BOTTOM = &H8 114 | Private Const BF_RECT = (BF_Left Or BF_TOP Or BF_Right Or BF_BOTTOM) 115 | 116 | Private Const BDR_RAISEDOUTER = &H1 117 | Private Const BDR_SUNKENOUTER = &H2 118 | Private Const BDR_RAISEDINNER = &H4 119 | Private Const BDR_SUNKENINNER = &H8 120 | 121 | Private Const WM_NCPAINT = &H85 122 | 123 | Private Type BORDERSTYLE_DATA 124 | Flags As Long 125 | Width As Long 126 | End Type 127 | 128 | Private WithEvents mScroll As cScrollBars 129 | Attribute mScroll.VB_VarHelpID = -1 130 | 131 | ' Public enums 132 | Public Enum vbExScrollBarVisibilityConstants 133 | vxScrollBarHide = 0 134 | vxScrollBarShow = 1 135 | vxScrollBarAuto = 2 136 | End Enum 137 | 138 | Public Enum vbExExtendedBorderStyleConstants 139 | vxEBSNone = 0 140 | vxEBSFlat1Pix = 1 141 | vxEBSFlat2Pix = 2 142 | vxEBSSunken2Pix = 3 143 | vxEBSRaised2Pix = 4 144 | vxEBSEtched2Pix = 5 145 | vxEBSSunkenOuter1Pix = 6 146 | vxEBSSunkenInner1Pix = 7 147 | vxEBSRaisedOuter1Pix = 8 148 | vxEBSRaisedInner1Pix = 9 149 | End Enum 150 | 151 | Public Event VScrollChange() 152 | Attribute VScrollChange.VB_Description = "Generated when VScrollValue changes." 153 | Attribute VScrollChange.VB_MemberFlags = "200" 154 | Public Event HScrollChange() 155 | Attribute HScrollChange.VB_Description = "Generated when HScrollValue changes." 156 | 157 | 158 | ' Persistable properties 159 | Private mBackColor As Long 160 | Private mBorderStyle As vbExExtendedBorderStyleConstants 161 | Private mBorderColor As Long 162 | Private mBottomFreeSpace As Single 163 | Private mRightFreeSpace As Single 164 | Private mVScrollBar As vbExScrollBarVisibilityConstants 165 | Private mHScrollBar As vbExScrollBarVisibilityConstants 166 | Private mAutoScrollOnFocus As Boolean 167 | 168 | ' Non persistable properties 169 | Private mVirtualHeight As Single 170 | Private mVScrollValue As Single 171 | Private mVirtualWidth As Single 172 | Private mHScrollValue As Single 173 | Private mAddingControls As Boolean 174 | 175 | ' Variables for vertical handling 176 | Private mMoveTop As Single 177 | Private mTempVScrollValue As Long 178 | Private mTempVScrollMax As Long 179 | Private mTempVirtualHeight As Long 180 | ' Variables for horizontal handling 181 | Private mMoveLeft As Single 182 | Private mTempHScrollValue As Long 183 | Private mTempHScrollMax As Long 184 | Private mTempVirtualWidth As Long 185 | ' Other variables 186 | Private mNoScroll As Boolean 187 | Private mAddingControls_v As Single 188 | Private mAddingControls_h As Single 189 | Private mFocusHwndList As Collection 190 | Private mUserControlHwnd As Long 191 | Private mUpdating As Boolean 192 | 193 | Private Const cDefaultBorderColor As Long = vbWindowFrame 194 | Private Const cDefaultBorderStyle = vxEBSFlat1Pix 195 | Private Const cDefaultBottomFreeSpace As Long = 300 ' twips 196 | Private mScrollBarHeight As Long 197 | Private mScrollBarWidth As Long 198 | Private mUserMode As Boolean 199 | Private mShown As Boolean 200 | Private mTopScrollBound As Single 201 | Private mSubclassed As Boolean 202 | 203 | Private Function IBSSubclass_MsgResponse(ByVal hWnd As Long, ByVal iMsg As Long) As Long 204 | IBSSubclass_MsgResponse = emrConsume 205 | End Function 206 | 207 | Private Sub IBSSubclass_UnsubclassIt() 208 | Unsubclass 209 | End Sub 210 | 211 | Private Function IBSSubclass_WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, wParam As Long, lParam As Long, bConsume As Boolean) As Long 212 | If iMsg = WM_NCPAINT Then 213 | Dim iWindowRect As RECT 214 | Dim iDC As Long 215 | Dim iBrush As Long 216 | Dim iRc As RECT 217 | Dim iColor As Long 218 | Dim iBs As BORDERSTYLE_DATA 219 | 220 | If (mBorderStyle = vxEBSNone) Or (mBorderStyle = vxEBSFlat1Pix) And (mBorderColor = vbWindowFrame) Or (mBorderStyle = vxEBSSunken2Pix) Then 221 | IBSSubclass_WindowProc = CallOldWindowProc(hWnd, iMsg, wParam, lParam) 222 | ElseIf (mBorderStyle = vxEBSFlat1Pix) Or (mBorderStyle = vxEBSFlat2Pix) Then 223 | iBs = GetBorderStyleData(mBorderStyle) 224 | 225 | iDC = GetWindowDC(hWnd) 226 | GetWindowRect hWnd, iWindowRect 227 | iWindowRect.Right = iWindowRect.Right - iWindowRect.Left 228 | iWindowRect.Bottom = iWindowRect.Bottom - iWindowRect.Top 229 | iWindowRect.Left = 0 230 | iWindowRect.Top = 0 231 | 232 | TranslateColor mBorderColor, 0&, iColor 233 | iBrush = CreateSolidBrush(iColor) 234 | 235 | iRc = iWindowRect 236 | iRc.Bottom = iRc.Top + iBs.Width 237 | FillRect iDC, iRc, iBrush 238 | 239 | iRc = iWindowRect 240 | iRc.Top = iRc.Bottom - iBs.Width 241 | FillRect iDC, iRc, iBrush 242 | 243 | iRc = iWindowRect 244 | iRc.Right = iRc.Left + iBs.Width 245 | FillRect iDC, iRc, iBrush 246 | 247 | iRc = iWindowRect 248 | iRc.Left = iRc.Right - iBs.Width 249 | FillRect iDC, iRc, iBrush 250 | 251 | DeleteObject iBrush 252 | 253 | ReleaseDC hWnd, iDC 254 | IBSSubclass_WindowProc = 0 255 | Else 256 | iBs = GetBorderStyleData(mBorderStyle) 257 | 258 | iDC = GetWindowDC(hWnd) 259 | GetWindowRect hWnd, iWindowRect 260 | iWindowRect.Right = iWindowRect.Right - iWindowRect.Left 261 | iWindowRect.Bottom = iWindowRect.Bottom - iWindowRect.Top 262 | iWindowRect.Left = 0 263 | iWindowRect.Top = 0 264 | 265 | Call DrawEdge(iDC, iWindowRect, iBs.Flags, BF_RECT) 266 | 267 | ReleaseDC hWnd, iDC 268 | IBSSubclass_WindowProc = 0 269 | End If 270 | End If 271 | End Function 272 | 273 | Private Sub tmrHScrollInit_Timer() 274 | tmrHScrollInit.Enabled = False 275 | pHScrollValue = Val(tmrHScrollInit.Tag) 276 | tmrHScrollInit.Tag = "" 277 | End Sub 278 | 279 | Private Sub tmrVScrollInit_Timer() 280 | tmrVScrollInit.Enabled = False 281 | pVScrollValue = Val(tmrVScrollInit.Tag) 282 | tmrVScrollInit.Tag = "" 283 | End Sub 284 | 285 | Private Sub tmrVScrollValue_Timer() 286 | tmrVScrollValue.Enabled = False 287 | mScroll.Value(efnSBIVertical) = Val(tmrVScrollValue.Tag) 288 | End Sub 289 | 290 | Private Sub UserControl_AmbientChanged(PropertyName As String) 291 | If PropertyName = "UserMode" Then mUserMode = Ambient.UserMode 292 | End Sub 293 | 294 | Private Sub tmrDontIncreaseMax_Timer() 295 | tmrDontIncreaseMax.Enabled = False 296 | End Sub 297 | 298 | Private Sub tmrMoveTop_Timer() 299 | Dim iCtl As Control 300 | Dim iLng As Long 301 | 302 | tmrMoveTop.Enabled = False 303 | On Error Resume Next 304 | For Each iCtl In UserControl.ContainedControls 305 | If TypeName(iCtl) = "Line" Then 306 | iCtl.Y1 = iCtl.Y1 - mMoveTop 307 | iCtl.Y2 = iCtl.Y2 - mMoveTop 308 | Else 309 | iCtl.Top = iCtl.Top - mMoveTop 310 | End If 311 | Next 312 | On Error GoTo 0 313 | 314 | iLng = mVScrollValue \ Screen.TwipsPerPixelY 315 | If mScroll.Value(efnSBIVertical) <> iLng Then 316 | mScroll.Value(efnSBIVertical) = iLng 317 | End If 318 | If (mMoveTop <> 0) And (Not mAddingControls_v) And (Not mUpdating) Then RaiseEvent VScrollChange 319 | mMoveTop = 0 320 | End Sub 321 | 322 | Private Sub tmrMoveLeft_Timer() 323 | Dim iCtl As Control 324 | Dim iLng As Long 325 | 326 | tmrMoveLeft.Enabled = False 327 | On Error Resume Next 328 | For Each iCtl In UserControl.ContainedControls 329 | If TypeName(iCtl) = "Line" Then 330 | iCtl.X1 = iCtl.X1 - mMoveLeft 331 | iCtl.X2 = iCtl.X2 - mMoveLeft 332 | Else 333 | iCtl.Left = iCtl.Left - mMoveLeft 334 | End If 335 | Next 336 | On Error GoTo 0 337 | 338 | iLng = mHScrollValue \ Screen.TwipsPerPixelX 339 | If mScroll.Value(efnSBIHorizontal) <> iLng Then 340 | mScroll.Value(efnSBIHorizontal) = iLng 341 | End If 342 | If (mMoveLeft <> 0) And (Not mAddingControls_h) And (Not mUpdating) Then RaiseEvent HScrollChange 343 | mMoveLeft = 0 344 | End Sub 345 | 346 | Private Sub AdjustVirtualSpaceToControls() 347 | Dim c As Long 348 | Dim iVal As Single 349 | Dim iVH As Single 350 | Dim iHW As Single 351 | 352 | CreateScrollBars 353 | 354 | iVH = mVirtualHeight 355 | On Error Resume Next 356 | For c = UserControl.ContainedControls.Count To 1 Step -1 357 | If TypeName(UserControl.ContainedControls(c - 1)) = "Line" Then 358 | If UserControl.ContainedControls(c - 1).Y2 > UserControl.ContainedControls(c - 1).Y1 Then 359 | iVal = UserControl.ContainedControls(c - 1).Y2 360 | Else 361 | iVal = UserControl.ContainedControls(c - 1).Y1 362 | End If 363 | Else 364 | iVal = UserControl.ContainedControls(c - 1).Top + UserControl.ContainedControls(c - 1).Height 365 | End If 366 | If (iVal + mBottomFreeSpace) > iVH Then 367 | iVH = (iVal + mBottomFreeSpace) 368 | End If 369 | Next c 370 | On Error GoTo 0 371 | 372 | If iVH < UserControl.ScaleHeight Then 373 | iVH = UserControl.ScaleHeight 374 | End If 375 | If iVH > mVirtualHeight Then 376 | pVirtualHeight = iVH 377 | End If 378 | 379 | iHW = mVirtualWidth 380 | On Error Resume Next 381 | For c = UserControl.ContainedControls.Count To 1 Step -1 382 | If TypeName(UserControl.ContainedControls(c - 1)) = "Line" Then 383 | If UserControl.ContainedControls(c - 1).X2 > UserControl.ContainedControls(c - 1).X1 Then 384 | iVal = UserControl.ContainedControls(c - 1).X2 385 | Else 386 | iVal = UserControl.ContainedControls(c - 1).X1 387 | End If 388 | Else 389 | iVal = UserControl.ContainedControls(c - 1).Left + UserControl.ContainedControls(c - 1).Width 390 | End If 391 | If (iVal + mRightFreeSpace) > iHW Then 392 | iHW = (iVal + mRightFreeSpace) 393 | End If 394 | Next c 395 | On Error GoTo 0 396 | 397 | If iHW < UserControl.ScaleWidth Then 398 | iHW = UserControl.ScaleWidth 399 | End If 400 | If iHW > mVirtualWidth Then 401 | pVirtualWidth = iHW 402 | End If 403 | 404 | End Sub 405 | 406 | Private Sub mScroll_Change(eBar As efnScrollBarsIdentificationConstants) 407 | mScroll_Scroll eBar 408 | End Sub 409 | 410 | Private Sub mScroll_Scroll(eBar As efnScrollBarsIdentificationConstants) 411 | Dim iLng As Long 412 | 413 | If eBar = efnSBIVertical Then 414 | pVScrollValue = Screen.TwipsPerPixelY * mScroll.Value(eBar) 415 | If Not Ambient.UserMode Then 416 | If mScroll.Value(efnSBIVertical) = mScroll.Max(efnSBIVertical) Then 417 | If Not tmrDontIncreaseMax.Enabled Then 418 | iLng = mScroll.Max(efnSBIVertical) * 1.1 419 | If iLng = mScroll.Max(efnSBIVertical) Then 420 | iLng = iLng + 10 421 | End If 422 | mScroll.Max(efnSBIVertical) = mScroll.Max(efnSBIVertical) * 1.1 423 | tmrDontIncreaseMax.Enabled = True 424 | End If 425 | End If 426 | End If 427 | ElseIf eBar = efnSBIHorizontal Then 428 | pHScrollValue = Screen.TwipsPerPixelX * mScroll.Value(eBar) 429 | If Not Ambient.UserMode Then 430 | If mScroll.Value(efnSBIHorizontal) = mScroll.Max(efnSBIHorizontal) Then 431 | If Not tmrDontIncreaseMax.Enabled Then 432 | iLng = mScroll.Max(efnSBIHorizontal) * 1.1 433 | If iLng = mScroll.Max(efnSBIHorizontal) Then 434 | iLng = iLng + 10 435 | End If 436 | mScroll.Max(efnSBIHorizontal) = mScroll.Max(efnSBIHorizontal) * 1.1 437 | tmrDontIncreaseMax.Enabled = True 438 | End If 439 | End If 440 | End If 441 | End If 442 | End Sub 443 | 444 | 445 | Public Property Get hWnd() As Long 446 | Attribute hWnd.VB_Description = "Returns the Windows handle of the control." 447 | hWnd = UserControl.hWnd 448 | End Property 449 | 450 | 451 | Public Property Get BackColor() As OLE_COLOR 452 | Attribute BackColor.VB_Description = "Returns/sets the background color" 453 | BackColor = mBackColor 454 | End Property 455 | 456 | Public Property Let BackColor(nValue As OLE_COLOR) 457 | If nValue <> mBackColor Then 458 | mBackColor = nValue 459 | If UserControl.BackColor <> mBackColor Then 460 | PropertyChanged "BackColor" 461 | UserControl.BackColor = mBackColor 462 | End If 463 | End If 464 | End Property 465 | 466 | 467 | Public Property Get BorderColor() As OLE_COLOR 468 | Attribute BorderColor.VB_Description = "Returns/sets the color of the border when it is set to a flat style." 469 | BorderColor = mBorderColor 470 | End Property 471 | 472 | Public Property Let BorderColor(nValue As OLE_COLOR) 473 | If nValue <> mBorderColor Then 474 | mBorderColor = nValue 475 | PropertyChanged "BorderColor" 476 | Call SetWindowPos(UserControl.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOACTIVATE Or SWP_FRAMECHANGED) 477 | End If 478 | End Property 479 | 480 | 481 | Private Sub UserControl_Initialize() 482 | mScrollBarHeight = ScaleY(GetSystemMetrics(SM_CYHSCROLL), vbPixels, vbTwips) 483 | mScrollBarWidth = ScaleY(GetSystemMetrics(SM_CXVSCROLL), vbPixels, vbTwips) 484 | End Sub 485 | 486 | Private Sub UserControl_Show() 487 | If mTempVScrollValue <> 0 Then 488 | mNoScroll = True 489 | mScroll.Max(efnSBIVertical) = mTempVScrollMax 490 | mScroll.Value(efnSBIVertical) = mTempVScrollValue 491 | mVScrollValue = Screen.TwipsPerPixelY * mScroll.Value(efnSBIVertical) 492 | mNoScroll = False 493 | mVirtualHeight = mTempVirtualHeight 494 | 'mScroll.Value(efnSBIVertical) = 0 495 | tmrMoveTop_Timer 496 | mTempVScrollValue = 0 497 | mTempVScrollMax = 0 498 | mTempVirtualHeight = 0 499 | End If 500 | If mTempHScrollValue <> 0 Then 501 | mNoScroll = True 502 | mScroll.Max(efnSBIHorizontal) = mTempHScrollMax 503 | mScroll.Value(efnSBIHorizontal) = mTempHScrollValue 504 | mHScrollValue = Screen.TwipsPerPixelX * mScroll.Value(efnSBIHorizontal) 505 | mNoScroll = False 506 | mVirtualWidth = mTempVirtualWidth 507 | ' mScroll.Value(efnSBIHorizontal) = 0 508 | tmrMoveLeft_Timer 509 | mTempHScrollValue = 0 510 | mTempHScrollMax = 0 511 | mTempVirtualWidth = 0 512 | End If 513 | mVirtualHeight = 0 514 | mVirtualWidth = 0 515 | AdjustVirtualSpaceToControls 516 | If UserControl.Ambient.UserMode Then 517 | tmrCheckFocus.Enabled = mAutoScrollOnFocus 518 | If mAutoScrollOnFocus Then BuildFocusList 519 | End If 520 | mShown = True 521 | End Sub 522 | 523 | Private Sub UserControl_InitProperties() 524 | BackColor = Ambient.BackColor 525 | mVScrollBar = vxScrollBarAuto 526 | mHScrollBar = vxScrollBarAuto 527 | mAutoScrollOnFocus = True 528 | mBorderColor = cDefaultBorderColor 529 | mBorderStyle = cDefaultBorderStyle 530 | mBottomFreeSpace = cDefaultBottomFreeSpace 531 | SetBorderStyle 532 | On Error Resume Next 533 | mUserMode = Ambient.UserMode 534 | mUserControlHwnd = UserControl.hWnd 535 | On Error GoTo 0 536 | If mUserControlHwnd <> 0 Then 537 | AttachMessage Me, mUserControlHwnd, WM_NCPAINT 538 | mSubclassed = True 539 | End If 540 | End Sub 541 | 542 | Private Sub UserControl_ReadProperties(PropBag As PropertyBag) 543 | 544 | BackColor = PropBag.ReadProperty("BackColor", vbButtonFace) 545 | mTempVScrollValue = PropBag.ReadProperty("SavedVScrollValue", 0) 546 | mTempVScrollMax = PropBag.ReadProperty("SavedVScrollMax", 0) 547 | mTempVirtualHeight = PropBag.ReadProperty("SavedVirtualHeight", 0) 548 | mTempHScrollValue = PropBag.ReadProperty("SavedHScrollValue", 0) 549 | mTempHScrollMax = PropBag.ReadProperty("SavedHScrollMax", 0) 550 | mTempVirtualWidth = PropBag.ReadProperty("SavedVirtualWidth", 0) 551 | mBottomFreeSpace = PropBag.ReadProperty("BottomFreeSpace", cDefaultBottomFreeSpace) 552 | mRightFreeSpace = PropBag.ReadProperty("RightFreeSpace", 0) 553 | mVScrollBar = PropBag.ReadProperty("VScrollBar", vxScrollBarAuto) 554 | mHScrollBar = PropBag.ReadProperty("HScrollBar", vxScrollBarAuto) 555 | mAutoScrollOnFocus = PropBag.ReadProperty("AutoScrollOnFocus", True) 556 | mBorderStyle = PropBag.ReadProperty("BorderStyle", cDefaultBorderStyle) 557 | mBorderColor = PropBag.ReadProperty("BorderColor", cDefaultBorderColor) 558 | mVScrollValue = PropBag.ReadProperty("VScrollValue", 0) 559 | mHScrollValue = PropBag.ReadProperty("HScrollValue", 0) 560 | mTopScrollBound = PropBag.ReadProperty("TopScrollBound", 0) 561 | 562 | SetBorderStyle 563 | CreateScrollBars 564 | On Error Resume Next 565 | mUserMode = Ambient.UserMode 566 | mUserControlHwnd = UserControl.hWnd 567 | On Error GoTo 0 568 | If mUserControlHwnd <> 0 Then 569 | AttachMessage Me, mUserControlHwnd, WM_NCPAINT 570 | mSubclassed = True 571 | End If 572 | End Sub 573 | 574 | Private Sub CreateScrollBars() 575 | If mScroll Is Nothing Then 576 | Set mScroll = New cScrollBars 577 | mScroll.Create UserControl.hWnd 578 | End If 579 | End Sub 580 | 581 | Private Sub UserControl_Terminate() 582 | Unsubclass 583 | Set mFocusHwndList = Nothing 584 | tmrCheckFocus.Enabled = False 585 | tmrDontIncreaseMax.Enabled = False 586 | tmrMoveLeft.Enabled = False 587 | tmrMoveTop.Enabled = False 588 | End Sub 589 | 590 | Private Sub Unsubclass() 591 | If mSubclassed Then 592 | DetachMessage Me, mUserControlHwnd, WM_NCPAINT 593 | mSubclassed = False 594 | End If 595 | End Sub 596 | 597 | Private Sub UserControl_WriteProperties(PropBag As PropertyBag) 598 | PropBag.WriteProperty "BackColor", mBackColor, vbButtonFace 599 | PropBag.WriteProperty "SavedVScrollValue", mScroll.Value(efnSBIVertical), 0 600 | PropBag.WriteProperty "SavedVScrollMax", mScroll.Max(efnSBIVertical), 0 601 | PropBag.WriteProperty "SavedVirtualHeight", mVirtualHeight, 0 602 | PropBag.WriteProperty "SavedHScrollValue", mScroll.Value(efnSBIHorizontal), 0 603 | PropBag.WriteProperty "SavedHScrollMax", mScroll.Max(efnSBIHorizontal), 0 604 | PropBag.WriteProperty "SavedVirtualWidth", mVirtualWidth, 0 605 | PropBag.WriteProperty "BottomFreeSpace", mBottomFreeSpace, cDefaultBottomFreeSpace 606 | PropBag.WriteProperty "RightFreeSpace", mRightFreeSpace, 0 607 | PropBag.WriteProperty "VScrollBar", mVScrollBar, vxScrollBarAuto 608 | PropBag.WriteProperty "HScrollBar", mHScrollBar, vxScrollBarAuto 609 | PropBag.WriteProperty "AutoScrollOnFocus", mAutoScrollOnFocus, True 610 | PropBag.WriteProperty "BorderStyle", mBorderStyle, cDefaultBorderStyle 611 | PropBag.WriteProperty "BorderColor", mBorderColor, cDefaultBorderColor 612 | PropBag.WriteProperty "VScrollValue", mVScrollValue, 0 613 | PropBag.WriteProperty "HScrollValue", mHScrollValue, 0 614 | PropBag.WriteProperty "TopScrollBound", mTopScrollBound, 0 615 | End Sub 616 | 617 | Private Sub UserControl_Resize() 618 | If (UserControl.ScaleX(UserControl.Width, vbTwips, vbPixels) < 75) Then 619 | UserControl.Width = 75 * Screen.TwipsPerPixelX 620 | End If 621 | If (UserControl.ScaleY(UserControl.Height, vbTwips, vbPixels) < 75) Then 622 | UserControl.Height = 75 * Screen.TwipsPerPixelY 623 | End If 624 | SetWindowRedraw UserControl.hWnd, False 625 | CreateScrollBars 626 | Update 627 | SetWindowRedraw UserControl.hWnd, True 628 | End Sub 629 | 630 | 631 | Public Property Get BottomFreeSpace() As Single 632 | Attribute BottomFreeSpace.VB_Description = "Returns/sets a value that determines the free space that will be left at the bottom of the virtual space." 633 | BottomFreeSpace = FixRoundingError(ToContainerSizeY(mBottomFreeSpace, vbTwips)) 634 | End Property 635 | 636 | Public Property Let BottomFreeSpace(nValue As Single) 637 | Dim iValue As Single 638 | 639 | If nValue < 0 Then 640 | RaiseError 380, TypeName(Me) ' invalid property value 641 | Exit Property 642 | End If 643 | 644 | iValue = FromContainerSizeY(nValue, vbTwips) 645 | If iValue <> mBottomFreeSpace Then 646 | mBottomFreeSpace = iValue 647 | PropertyChanged "BottomFreeSpace" 648 | AdjustVirtualSpaceToControls 649 | End If 650 | End Property 651 | 652 | 653 | Public Property Get RightFreeSpace() As Single 654 | Attribute RightFreeSpace.VB_Description = "Returns/sets a value that determines the free space that will be left at the right of the virtual space." 655 | RightFreeSpace = FixRoundingError(ToContainerSizeX(mRightFreeSpace, vbTwips)) 656 | End Property 657 | 658 | Public Property Let RightFreeSpace(nValue As Single) 659 | Dim iValue As Single 660 | 661 | If nValue < 0 Then 662 | RaiseError 380, TypeName(Me) ' invalid property value 663 | Exit Property 664 | End If 665 | 666 | iValue = FromContainerSizeX(nValue, vbTwips) 667 | If iValue <> mRightFreeSpace Then 668 | mRightFreeSpace = iValue 669 | PropertyChanged "RightFreeSpace" 670 | AdjustVirtualSpaceToControls 671 | End If 672 | End Property 673 | 674 | 675 | Public Property Get VScrollValue() As Single 676 | Attribute VScrollValue.VB_Description = "Returns or sets a value that idicates the vertical scroll actual position." 677 | VScrollValue = FixRoundingError(ToContainerSizeY(mVScrollValue, vbTwips)) 678 | End Property 679 | 680 | Public Property Let VScrollValue(nValue As Single) 681 | pVScrollValue = FromContainerSizeY(nValue, vbTwips) 682 | tmrMoveTop_Timer 683 | PropertyChanged "VScrollValue" 684 | End Property 685 | 686 | Private Property Let pVScrollValue(nValue As Single) 687 | If Not mShown Then 688 | tmrVScrollInit.Tag = nValue 689 | tmrVScrollInit.Enabled = True 690 | Exit Property 691 | End If 692 | If mNoScroll Then Exit Property 693 | ' If nValue < 0 Then 694 | ' RaiseError 380, TypeName(Me) ' invalid property value 695 | ' Exit Property 696 | ' End If 697 | If nValue <> mVScrollValue Then 698 | If nValue > (mVirtualHeight - UserControl.ScaleHeight) Then 699 | If Ambient.UserMode Then 700 | nValue = mVirtualHeight - UserControl.ScaleHeight 701 | Else 702 | pVirtualHeight = nValue + UserControl.ScaleHeight 703 | End If 704 | End If 705 | If mTopScrollBound <> 0 Then 706 | If nValue > (mTopScrollBound - UserControl.ScaleHeight) Then 707 | tmrVScrollValue.Tag = (mTopScrollBound - UserControl.ScaleHeight) / Screen.TwipsPerPixelY 708 | tmrVScrollValue.Enabled = True 709 | End If 710 | End If 711 | If Not tmrVScrollValue.Enabled Then 712 | mMoveTop = mMoveTop + nValue - mVScrollValue 713 | mVScrollValue = nValue 714 | tmrMoveTop.Enabled = True 715 | End If 716 | End If 717 | End Property 718 | 719 | 720 | Public Property Get HScrollValue() As Single 721 | Attribute HScrollValue.VB_Description = "Returns or sets a value that idicates the horizontal scroll actual position." 722 | HScrollValue = FixRoundingError(ToContainerSizeX(mHScrollValue, vbTwips)) 723 | End Property 724 | 725 | Public Property Let HScrollValue(nValue As Single) 726 | pHScrollValue = FromContainerSizeY(nValue, vbTwips) 727 | tmrMoveLeft_Timer 728 | PropertyChanged "HScrollValue" 729 | End Property 730 | 731 | Private Property Let pHScrollValue(nValue As Single) 732 | If Not mShown Then 733 | tmrHScrollInit.Tag = nValue 734 | tmrHScrollInit.Enabled = True 735 | Exit Property 736 | End If 737 | If mNoScroll Then Exit Property 738 | ' If nValue < 0 Then 739 | ' RaiseError 380, TypeName(Me) ' invalid property value 740 | ' Exit Property 741 | ' End If 742 | 743 | If nValue <> mHScrollValue Then 744 | If nValue > (mVirtualWidth - UserControl.ScaleWidth) Then 745 | If Ambient.UserMode Then 746 | nValue = mVirtualWidth - UserControl.ScaleWidth 747 | Else 748 | pVirtualWidth = nValue + UserControl.ScaleWidth 749 | End If 750 | End If 751 | mMoveLeft = mMoveLeft + nValue - mHScrollValue 752 | mHScrollValue = nValue 753 | tmrMoveLeft.Enabled = True 754 | End If 755 | End Property 756 | 757 | 758 | Public Property Get VirtualHeight() As Single 759 | Attribute VirtualHeight.VB_Description = "Returns or sets a value that determines the height of the virtual space where the controls are located." 760 | Attribute VirtualHeight.VB_MemberFlags = "200" 761 | On Error GoTo ErrExit 762 | 763 | VirtualHeight = FixRoundingError(ToContainerSizeY(mVirtualHeight, vbTwips)) 764 | 765 | If Not Ambient.UserMode Then 766 | If Abs(VirtualHeight + mScrollBarHeight + GetBorderStyleData(mBorderStyle).Width * Screen.TwipsPerPixelY * 2 - UserControl.Extender.Height) < Screen.TwipsPerPixelY Then 767 | VirtualHeight = UserControl.Extender.Height 768 | End If 769 | End If 770 | 771 | ErrExit: 772 | End Property 773 | 774 | Public Property Let VirtualHeight(ByVal nValue As Single) 775 | On Error GoTo ErrExit 776 | 777 | If nValue < UserControl.Extender.Height Then 778 | nValue = UserControl.Extender.Height 779 | End If 780 | If Not Ambient.UserMode Then 781 | If Abs(nValue + mScrollBarHeight + GetBorderStyleData(mBorderStyle).Width * Screen.TwipsPerPixelY * 2 - UserControl.Extender.Height) < Screen.TwipsPerPixelY Then 782 | nValue = UserControl.Extender.Height - mScrollBarHeight 783 | End If 784 | End If 785 | If nValue < 0 Then nValue = 0 786 | 787 | pVirtualHeight = FromContainerSizeY(nValue, vbTwips) 788 | PropertyChanged "VirtualHeight" 789 | ErrExit: 790 | End Property 791 | 792 | Private Property Let pVirtualHeight(nValue As Single) 793 | If nValue <> mVirtualHeight Then 794 | Dim iVisible As Boolean 795 | 796 | iVisible = mScroll.Visible(efnSBIVertical) 797 | mVirtualHeight = nValue 798 | 799 | If mVirtualHeight < UserControl.ScaleHeight Then 800 | mVirtualHeight = UserControl.ScaleHeight 801 | End If 802 | If (mVirtualHeight > UserControl.ScaleHeight) Then 803 | mScroll.LargeChange(efnSBIVertical) = UserControl.ScaleHeight * 0.9 \ Screen.TwipsPerPixelY 804 | mScroll.SmallChange(efnSBIVertical) = mScroll.LargeChange(efnSBIVertical) / 10 805 | mScroll.Max(efnSBIVertical) = (mVirtualHeight - UserControl.ScaleHeight) \ Screen.TwipsPerPixelY 806 | mScroll.Visible(efnSBIVertical) = (mVScrollBar <> vxScrollBarHide) 807 | mScroll.Enabled(efnSBIVertical) = True 808 | Else 809 | If Ambient.UserMode Then 810 | mScroll.Visible(efnSBIVertical) = (mVScrollBar = vxScrollBarShow) 811 | mScroll.Enabled(efnSBIVertical) = False 812 | Else 813 | mScroll.LargeChange(efnSBIVertical) = UserControl.ScaleHeight \ Screen.TwipsPerPixelY \ 2 814 | mScroll.SmallChange(efnSBIVertical) = mScroll.LargeChange(efnSBIVertical) / 10 815 | mScroll.Max(efnSBIVertical) = UserControl.ScaleHeight \ Screen.TwipsPerPixelY 816 | mScroll.Visible(efnSBIVertical) = (mVScrollBar <> vxScrollBarHide) 817 | mScroll.Enabled(efnSBIVertical) = True 818 | End If 819 | End If 820 | mScroll.Value(efnSBIVertical) = mVScrollValue \ Screen.TwipsPerPixelY 821 | If mScroll.Visible(efnSBIVertical) <> iVisible Then 822 | If mVirtualWidth <> 0 Then 823 | mVirtualWidth = mVirtualWidth - 1 824 | pVirtualWidth = mVirtualWidth + 1 825 | End If 826 | End If 827 | If mTopScrollBound > nValue Then 828 | mTopScrollBound = 0 829 | End If 830 | End If 831 | End Property 832 | 833 | 834 | Public Property Get VirtualWidth() As Single 835 | Attribute VirtualWidth.VB_Description = "Returns or sets a value that determines the width of the virtual space where the controls are located." 836 | On Error GoTo ErrExit 837 | 838 | VirtualWidth = FixRoundingError(ToContainerSizeX(mVirtualWidth, vbTwips)) 839 | If Not Ambient.UserMode Then 840 | If Abs(VirtualWidth + mScrollBarWidth + GetBorderStyleData(mBorderStyle).Width * Screen.TwipsPerPixelX * 2 - UserControl.Extender.Width) < Screen.TwipsPerPixelX Then 841 | VirtualWidth = UserControl.Extender.Width 842 | End If 843 | End If 844 | 845 | ErrExit: 846 | End Property 847 | 848 | Public Property Let VirtualWidth(nValue As Single) 849 | On Error GoTo ErrExit 850 | 851 | If nValue < UserControl.Extender.Width Then 852 | nValue = UserControl.Extender.Width 853 | End If 854 | If Not Ambient.UserMode Then 855 | If Abs(nValue + mScrollBarWidth + GetBorderStyleData(mBorderStyle).Width * Screen.TwipsPerPixelX * 2 - UserControl.Extender.Width) < Screen.TwipsPerPixelX Then 856 | nValue = UserControl.Extender.Width - mScrollBarWidth 857 | End If 858 | End If 859 | If nValue < 0 Then nValue = 0 860 | 861 | pVirtualWidth = FromContainerSizeY(nValue, vbTwips) 862 | PropertyChanged "VirtualWidth" 863 | ErrExit: 864 | End Property 865 | 866 | Private Property Let pVirtualWidth(nValue As Single) 867 | If nValue <> mVirtualWidth Then 868 | Dim iVisible As Boolean 869 | 870 | iVisible = mScroll.Visible(efnSBIHorizontal) 871 | mVirtualWidth = nValue 872 | 873 | If mVirtualWidth < UserControl.ScaleWidth Then 874 | mVirtualWidth = UserControl.ScaleWidth 875 | End If 876 | If (mVirtualWidth > UserControl.ScaleWidth) Then 877 | mScroll.LargeChange(efnSBIHorizontal) = UserControl.ScaleWidth * 0.9 \ Screen.TwipsPerPixelX 878 | mScroll.SmallChange(efnSBIHorizontal) = mScroll.LargeChange(efnSBIHorizontal) / 10 879 | mScroll.Max(efnSBIHorizontal) = (mVirtualWidth - UserControl.ScaleWidth) \ Screen.TwipsPerPixelX 880 | mScroll.Visible(efnSBIHorizontal) = (mHScrollBar <> vxScrollBarHide) 881 | mScroll.Enabled(efnSBIHorizontal) = True 882 | Else 883 | If Ambient.UserMode Then 884 | mScroll.Visible(efnSBIHorizontal) = (mHScrollBar = vxScrollBarShow) 885 | mScroll.Enabled(efnSBIHorizontal) = False 886 | Else 887 | mScroll.LargeChange(efnSBIHorizontal) = UserControl.ScaleWidth \ Screen.TwipsPerPixelX \ 2 888 | mScroll.SmallChange(efnSBIHorizontal) = mScroll.LargeChange(efnSBIHorizontal) / 10 889 | mScroll.Max(efnSBIHorizontal) = UserControl.ScaleWidth \ Screen.TwipsPerPixelX 890 | mScroll.Visible(efnSBIHorizontal) = (mHScrollBar <> vxScrollBarHide) 891 | mScroll.Enabled(efnSBIHorizontal) = True 892 | End If 893 | End If 894 | mScroll.Value(efnSBIHorizontal) = mHScrollValue \ Screen.TwipsPerPixelX 895 | If mScroll.Visible(efnSBIHorizontal) <> iVisible Then 896 | If mVirtualHeight <> 0 Then 897 | mVirtualHeight = mVirtualHeight - 1 898 | pVirtualHeight = mVirtualHeight + 1 899 | End If 900 | End If 901 | End If 902 | End Property 903 | 904 | 905 | Private Function ContainerScaleMode() As ScaleModeConstants 906 | ContainerScaleMode = vbTwips 907 | On Error Resume Next 908 | ContainerScaleMode = UserControl.Extender.Container.ScaleMode 909 | End Function 910 | 911 | Private Function FromContainerSizeY(nValue As Variant, Optional nToScale As ScaleModeConstants = vbTwips) As Single 912 | FromContainerSizeY = UserControl.ScaleY(nValue, ContainerScaleMode, nToScale) 913 | End Function 914 | 915 | Private Function ToContainerSizeY(nValue As Variant, Optional nFromScale As ScaleModeConstants = vbTwips) As Single 916 | ToContainerSizeY = UserControl.ScaleY(nValue, nFromScale, ContainerScaleMode) 917 | End Function 918 | 919 | 920 | Private Function FromContainerSizeX(nValue As Variant, Optional nToScale As ScaleModeConstants = vbTwips) As Single 921 | FromContainerSizeX = UserControl.ScaleX(nValue, ContainerScaleMode, nToScale) 922 | End Function 923 | 924 | Private Function ToContainerSizeX(nValue As Variant, Optional nFromScale As ScaleModeConstants = vbTwips) As Single 925 | ToContainerSizeX = UserControl.ScaleY(nValue, nFromScale, ContainerScaleMode) 926 | End Function 927 | 928 | Private Function FixRoundingError(nNumber As Single, Optional nDecimals As Long = 3) As Single 929 | Dim iNum As Single 930 | 931 | iNum = Round(nNumber * 10 ^ nDecimals) / 10 ^ nDecimals 932 | 933 | If iNum = Int(iNum) Then 934 | FixRoundingError = iNum 935 | Else 936 | If (ContainerScaleMode = vbTwips) Or (ContainerScaleMode = vbPixels) Then 937 | FixRoundingError = Round(nNumber) 938 | Else 939 | FixRoundingError = nNumber 940 | End If 941 | End If 942 | End Function 943 | 944 | Public Property Get VScrollBar() As vbExScrollBarVisibilityConstants 945 | Attribute VScrollBar.VB_Description = "Returns or sets a value that determines the vertical scrollbar visibility at run time." 946 | VScrollBar = mVScrollBar 947 | End Property 948 | 949 | Public Property Let VScrollBar(nValue As vbExScrollBarVisibilityConstants) 950 | If (nValue < 0) Or (nValue > 2) Then 951 | RaiseError 380, TypeName(Me) ' invalid property value 952 | Exit Property 953 | End If 954 | If nValue <> mVScrollBar Then 955 | mVScrollBar = nValue 956 | PropertyChanged "VScrollBar" 957 | End If 958 | End Property 959 | 960 | 961 | Public Property Get HScrollBar() As vbExScrollBarVisibilityConstants 962 | Attribute HScrollBar.VB_Description = "Returns or sets a value that determines the horizontal scrollbar visibility at run time." 963 | HScrollBar = mHScrollBar 964 | End Property 965 | 966 | Public Property Let HScrollBar(nValue As vbExScrollBarVisibilityConstants) 967 | If (nValue < 0) Or (nValue > 2) Then 968 | RaiseError 380, TypeName(Me) ' invalid property value 969 | Exit Property 970 | End If 971 | If nValue <> mHScrollBar Then 972 | mHScrollBar = nValue 973 | PropertyChanged "HScrollBar" 974 | End If 975 | End Property 976 | 977 | 978 | Public Property Get VScrollMax() As Single 979 | Attribute VScrollMax.VB_Description = "Returns a value that idicates the maximum value that VScrollValue can take." 980 | VScrollMax = FixRoundingError(ToContainerSizeY(mScroll.Max(efnSBIVertical), vbPixels)) 981 | End Property 982 | 983 | Public Property Get HScrollMax() As Single 984 | Attribute HScrollMax.VB_Description = "Returns a value that idicates the maximum value that HScrollValue can take." 985 | HScrollMax = FixRoundingError(ToContainerSizeX(mScroll.Max(efnSBIHorizontal), vbPixels)) 986 | End Property 987 | 988 | 989 | Public Property Get BorderStyle() As vbExExtendedBorderStyleConstants 990 | Attribute BorderStyle.VB_Description = "Returns/sets a value that determines how the border of the control looks like." 991 | BorderStyle = mBorderStyle 992 | End Property 993 | 994 | Public Property Let BorderStyle(nValue As vbExExtendedBorderStyleConstants) 995 | If nValue <> mBorderStyle Then 996 | mBorderStyle = nValue 997 | PropertyChanged "BorderStyle" 998 | SetBorderStyle 999 | Call SetWindowPos(UserControl.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOACTIVATE Or SWP_FRAMECHANGED) 1000 | End If 1001 | End Property 1002 | 1003 | 1004 | Public Property Get AutoScrollOnFocus() As Boolean 1005 | Attribute AutoScrollOnFocus.VB_Description = "Returns/sets a value that determines if when a contained control out of view gets the focus, if it will automatically scroll to show that control." 1006 | AutoScrollOnFocus = mAutoScrollOnFocus 1007 | End Property 1008 | 1009 | Public Property Let AutoScrollOnFocus(nValue As Boolean) 1010 | If nValue <> mAutoScrollOnFocus Then 1011 | mAutoScrollOnFocus = nValue 1012 | PropertyChanged "AutoScrollOnFocus" 1013 | If UserControl.Ambient.UserMode Then 1014 | tmrCheckFocus.Enabled = mAutoScrollOnFocus 1015 | If mAutoScrollOnFocus Then BuildFocusList 1016 | End If 1017 | End If 1018 | End Property 1019 | 1020 | Private Sub BuildFocusList() 1021 | Dim iCtl As Control 1022 | Dim iHwnd As Long 1023 | 1024 | Set mFocusHwndList = New Collection 1025 | On Error Resume Next 1026 | For Each iCtl In UserControl.ContainedControls 1027 | iHwnd = 0 1028 | iHwnd = iCtl.hWnd 1029 | If iHwnd <> 0 Then 1030 | mFocusHwndList.Add iHwnd, CStr(iHwnd) 1031 | End If 1032 | Next 1033 | End Sub 1034 | 1035 | Private Sub tmrCheckFocus_Timer() 1036 | Dim iCtl As Control 1037 | Dim iHwnd As Long 1038 | Dim iHwnd2 As Long 1039 | Static sLastHwnd As Long 1040 | 1041 | On Error GoTo TheExit 1042 | Set iCtl = Screen.ActiveControl 1043 | iHwnd = GetFocus 1044 | 1045 | iHwnd2 = 0 1046 | iHwnd2 = mFocusHwndList(CStr(iHwnd)) 1047 | If iHwnd2 <> 0 Then 1048 | If iHwnd <> sLastHwnd Then 1049 | Set iCtl = GetControlByHwnd(iHwnd) 1050 | sLastHwnd = iHwnd 1051 | If Not iCtl Is Nothing Then 1052 | EnsureControlVisible iCtl 1053 | End If 1054 | End If 1055 | End If 1056 | 1057 | TheExit: 1058 | End Sub 1059 | 1060 | Private Function GetControlByHwnd(nHwnd As Long) As Object 1061 | Dim iCtl As Control 1062 | Dim iHwnd As Long 1063 | 1064 | On Error Resume Next 1065 | For Each iCtl In UserControl.ContainedControls 1066 | iHwnd = 0 1067 | iHwnd = iCtl.hWnd 1068 | If iHwnd <> 0 Then 1069 | If iHwnd = nHwnd Then 1070 | Set GetControlByHwnd = iCtl 1071 | Exit Function 1072 | End If 1073 | End If 1074 | Next 1075 | End Function 1076 | 1077 | 1078 | Public Sub Update() 1079 | Attribute Update.VB_Description = "Updates the virtual space dimensions." 1080 | Dim V As Single 1081 | Dim h As Single 1082 | 1083 | mUpdating = True 1084 | V = VScrollValue 1085 | h = HScrollValue 1086 | VScrollValue = 0 1087 | HScrollValue = 0 1088 | mVirtualHeight = 0 1089 | mVirtualWidth = 0 1090 | AdjustVirtualSpaceToControls 1091 | If V <> 0 Then 1092 | VScrollValue = V 1093 | End If 1094 | If h <> 0 Then 1095 | HScrollValue = h 1096 | End If 1097 | mUpdating = False 1098 | End Sub 1099 | 1100 | 1101 | Public Property Get AddingControls() As Boolean 1102 | Attribute AddingControls.VB_Description = "Use this property when adding controls to the container at run time." 1103 | Attribute AddingControls.VB_MemberFlags = "400" 1104 | AddingControls = mAddingControls 1105 | End Property 1106 | 1107 | Public Property Let AddingControls(nValue As Boolean) 1108 | If nValue <> mAddingControls Then 1109 | If nValue Then mAddingControls = True 1110 | If nValue Then 1111 | mAddingControls_v = VScrollValue 1112 | mAddingControls_h = HScrollValue 1113 | VScrollValue = 0 1114 | HScrollValue = 0 1115 | Else 1116 | mVirtualHeight = 0 1117 | mVirtualWidth = 0 1118 | AdjustVirtualSpaceToControls 1119 | If mAddingControls_v <> 0 Then 1120 | VScrollValue = mAddingControls_v 1121 | End If 1122 | If mAddingControls_h <> 0 Then 1123 | HScrollValue = mAddingControls_h 1124 | End If 1125 | Update 1126 | mAddingControls = False 1127 | End If 1128 | End If 1129 | End Property 1130 | 1131 | Public Sub EnsureControlVisible(nControl As Object) 1132 | Attribute EnsureControlVisible.VB_Description = "Ensures that the control referenced in the nControl parameter is visible on the container." 1133 | Dim iSW As Single 1134 | Dim iSH As Single 1135 | Dim iVal As Single 1136 | Dim iCtl As Control 1137 | Dim iFound As Boolean 1138 | 1139 | For Each iCtl In UserControl.ContainedControls 1140 | If iCtl Is nControl Then 1141 | iFound = True 1142 | Exit For 1143 | End If 1144 | Next 1145 | 1146 | If Not iFound Then 1147 | RaiseError 1390, TypeName(Me), "The contained controls collection could not be found." 1148 | Exit Sub 1149 | End If 1150 | 1151 | If mScroll.Visible(efnSBIHorizontal) Then 1152 | iSW = ToContainerSizeX(UserControl.ScaleWidth, vbTwips) 1153 | If iCtl.Left + iCtl.Width > iSW Then 1154 | HScrollValue = HScrollValue + iCtl.Left + iCtl.Width + ToContainerSizeX(60, vbTwips) - iSW 1155 | ElseIf iCtl.Left < 0 Then 1156 | iVal = HScrollValue + iCtl.Left - ToContainerSizeX(60, vbTwips) 1157 | If iVal < 0 Then iVal = 0 1158 | HScrollValue = iVal 1159 | End If 1160 | End If 1161 | 1162 | If mScroll.Visible(efnSBIVertical) Then 1163 | iSH = ToContainerSizeY(UserControl.ScaleHeight, vbTwips) 1164 | If iCtl.Top + iCtl.Height > iSH Then 1165 | VScrollValue = VScrollValue + iCtl.Top + iCtl.Height + ToContainerSizeY(60, vbTwips) - iSH 1166 | ElseIf iCtl.Top < 0 Then 1167 | iVal = VScrollValue + iCtl.Top - ToContainerSizeY(60, vbTwips) 1168 | If iVal < 0 Then iVal = 0 1169 | VScrollValue = iVal 1170 | End If 1171 | End If 1172 | End Sub 1173 | 1174 | Private Function GetBorderStyleData(nBs As vbExExtendedBorderStyleConstants) As BORDERSTYLE_DATA 1175 | Dim iRet As BORDERSTYLE_DATA 1176 | 1177 | Select Case nBs 1178 | Case vxEBSNone 1179 | iRet.Flags = 0 1180 | iRet.Width = 0 1181 | Case vxEBSFlat1Pix 1182 | iRet.Flags = -1 1183 | iRet.Width = 1 1184 | Case vxEBSSunkenOuter1Pix 1185 | iRet.Flags = BDR_SUNKENOUTER 1186 | iRet.Width = 1 1187 | Case vxEBSSunkenInner1Pix 1188 | iRet.Flags = BDR_SUNKENINNER 1189 | iRet.Width = 1 1190 | Case vxEBSRaisedOuter1Pix 1191 | iRet.Flags = BDR_RAISEDOUTER 1192 | iRet.Width = 1 1193 | Case vxEBSRaisedInner1Pix 1194 | iRet.Flags = BDR_RAISEDINNER 1195 | iRet.Width = 1 1196 | Case vxEBSFlat2Pix 1197 | iRet.Flags = -1 1198 | iRet.Width = 2 1199 | Case vxEBSSunken2Pix 1200 | iRet.Flags = BDR_SUNKENOUTER Or BDR_SUNKENINNER 1201 | iRet.Width = 2 1202 | Case vxEBSRaised2Pix 1203 | iRet.Flags = BDR_RAISEDOUTER Or BDR_RAISEDINNER 1204 | iRet.Width = 2 1205 | Case vxEBSEtched2Pix 1206 | iRet.Flags = BDR_SUNKENOUTER Or BDR_RAISEDINNER 1207 | iRet.Width = 2 1208 | End Select 1209 | 1210 | GetBorderStyleData = iRet 1211 | End Function 1212 | 1213 | Private Sub SetBorderStyle() 1214 | Dim iBs As BORDERSTYLE_DATA 1215 | 1216 | iBs = GetBorderStyleData(mBorderStyle) 1217 | If iBs.Width = 0 Then 1218 | UserControl.Appearance = 1 1219 | UserControl.BorderStyle = 0 1220 | ElseIf iBs.Width = 1 Then 1221 | UserControl.Appearance = 0 1222 | UserControl.BorderStyle = 1 1223 | Else 1224 | UserControl.Appearance = 1 1225 | UserControl.BorderStyle = 1 1226 | End If 1227 | UserControl.BackColor = mBackColor 1228 | End Sub 1229 | 1230 | Private Sub SetWindowRedraw(nHwnd As Long, nRedraw As Boolean, Optional nForce As Boolean) 1231 | 1232 | If Not nRedraw Then 1233 | If IsWindowVisible(nHwnd) = 0 Then Exit Sub 1234 | End If 1235 | 1236 | Static sHwnds() As Long 1237 | Static sCalls() As Long 1238 | Dim c As Long 1239 | Dim t As Long 1240 | Dim i As Long 1241 | 1242 | i = 0 1243 | On Error Resume Next 1244 | Err.Clear 1245 | t = UBound(sHwnds) 1246 | If Err.Number = 9 Then 1247 | ReDim sHwnds(0) 1248 | ReDim sCalls(0) 1249 | t = 0 1250 | Else 1251 | For c = 1 To t 1252 | If sHwnds(c) = nHwnd Then 1253 | i = c 1254 | Exit For 1255 | End If 1256 | Next c 1257 | End If 1258 | On Error GoTo 0 1259 | If (i = 0) Then 1260 | If nRedraw Then Exit Sub 1261 | ReDim Preserve sHwnds(t + 1) 1262 | sHwnds(t + 1) = nHwnd 1263 | ReDim Preserve sCalls(t + 1) 1264 | sCalls(t + 1) = 1 1265 | i = 1 1266 | Else 1267 | If nRedraw Then 1268 | sCalls(i) = sCalls(i) - 1 1269 | If sCalls(i) < 0 Then sCalls(i) = 0 1270 | Else 1271 | sCalls(i) = sCalls(i) + 1 1272 | End If 1273 | End If 1274 | If nRedraw And nForce Then 1275 | SendMessageLong nHwnd, WM_SETREDRAW, True, 0& 1276 | RedrawWindow nHwnd, ByVal 0&, 0&, RDW_INVALIDATE Or RDW_ALLCHILDREN 1277 | sCalls(i) = 0 1278 | Else 1279 | Select Case sCalls(i) 1280 | Case 1 1281 | SendMessageLong nHwnd, WM_SETREDRAW, False, 0& 1282 | Case 0 1283 | SendMessageLong nHwnd, WM_SETREDRAW, True, 0& 1284 | RedrawWindow nHwnd, ByVal 0&, 0&, RDW_INVALIDATE Or RDW_ALLCHILDREN 1285 | End Select 1286 | End If 1287 | End Sub 1288 | 1289 | Private Sub RaiseError(ByVal Number As Long, Optional ByVal Source As Variant, Optional ByVal Description As Variant, Optional ByVal HelpFile As Variant, Optional ByVal HelpContext As Variant) 1290 | If InIDE Then 1291 | On Error Resume Next 1292 | Err.Raise Number, Source, Description, HelpFile, HelpContext 1293 | MsgBox "Error " & Err.Number & ". " & Err.Description, vbCritical 1294 | Else 1295 | Err.Raise Number, Source, Description, HelpFile, HelpContext 1296 | End If 1297 | End Sub 1298 | 1299 | Private Function InIDE() As Boolean 1300 | Static sValue As Long 1301 | 1302 | If sValue = 0 Then 1303 | Err.Clear 1304 | On Error Resume Next 1305 | Debug.Print 1 / 0 1306 | If Err.Number Then 1307 | sValue = 1 1308 | Else 1309 | sValue = 2 1310 | End If 1311 | Err.Clear 1312 | End If 1313 | InIDE = (sValue = 1) 1314 | End Function 1315 | 1316 | Public Property Let TopScrollBound(ByVal nValue As Single) 1317 | If nValue >= VirtualHeight Then nValue = 0 1318 | If nValue <> mTopScrollBound Then 1319 | mTopScrollBound = FromContainerSizeY(nValue, vbTwips) 1320 | PropertyChanged "TopScrollBound" 1321 | End If 1322 | End Property 1323 | 1324 | Public Property Get TopScrollBound() As Single 1325 | If mTopScrollBound = 0 Then 1326 | TopScrollBound = FixRoundingError(ToContainerSizeY(mVirtualHeight, vbTwips)) 1327 | Else 1328 | TopScrollBound = FixRoundingError(ToContainerSizeY(mTopScrollBound, vbTwips)) 1329 | End If 1330 | End Property 1331 | -------------------------------------------------------------------------------- /control-source/ctlScrollableContainer.ctx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ScrollableContainer/7e3f80a3171e11940aa9b1ee6f273d6884902a75/control-source/ctlScrollableContainer.ctx -------------------------------------------------------------------------------- /control-source/ptpScrollableContainer.pag: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.PropertyPage ptpScrollableContainer 3 | Caption = "General" 4 | ClientHeight = 3912 5 | ClientLeft = 0 6 | ClientTop = 0 7 | ClientWidth = 6084 8 | BeginProperty Font 9 | Name = "Tahoma" 10 | Size = 7.8 11 | Charset = 0 12 | Weight = 400 13 | Underline = 0 'False 14 | Italic = 0 'False 15 | Strikethrough = 0 'False 16 | EndProperty 17 | LockControls = -1 'True 18 | PaletteMode = 0 'Halftone 19 | ScaleHeight = 3912 20 | ScaleWidth = 6084 21 | Begin VB.TextBox txtTopScrollBound 22 | Height = 300 23 | Left = 1548 24 | TabIndex = 13 25 | Top = 2124 26 | Width = 2000 27 | End 28 | Begin VB.CheckBox chkAutoScrollOnFocus 29 | Caption = "AutoScrollOnFocus" 30 | Height = 192 31 | Left = 1548 32 | TabIndex = 20 33 | Top = 3492 34 | Width = 2208 35 | End 36 | Begin VB.ComboBox cboHScrollBar 37 | Height = 288 38 | Left = 1548 39 | Style = 2 'Dropdown List 40 | TabIndex = 19 41 | Top = 3096 42 | Width = 2000 43 | End 44 | Begin VB.ComboBox cboVScrollBar 45 | Height = 288 46 | Left = 1548 47 | Style = 2 'Dropdown List 48 | TabIndex = 17 49 | Top = 2772 50 | Width = 2000 51 | End 52 | Begin VB.TextBox txtHScrollValue 53 | Height = 300 54 | Left = 1548 55 | TabIndex = 11 56 | Top = 1800 57 | Width = 2000 58 | End 59 | Begin VB.TextBox txtVirtualHeight 60 | Height = 300 61 | Left = 1548 62 | TabIndex = 1 63 | Top = 180 64 | Width = 2000 65 | End 66 | Begin VB.ComboBox cboBorderStyle 67 | Height = 288 68 | Left = 1548 69 | Style = 2 'Dropdown List 70 | TabIndex = 15 71 | Top = 2448 72 | Width = 2000 73 | End 74 | Begin VB.TextBox txtVScrollValue 75 | Height = 300 76 | Left = 1548 77 | TabIndex = 9 78 | Top = 1476 79 | Width = 2000 80 | End 81 | Begin VB.TextBox txtRightFreeSpace 82 | Height = 300 83 | Left = 1548 84 | TabIndex = 7 85 | Top = 1152 86 | Width = 2000 87 | End 88 | Begin VB.TextBox txtBottomFreeSpace 89 | Height = 300 90 | Left = 1548 91 | TabIndex = 5 92 | Top = 828 93 | Width = 2000 94 | End 95 | Begin VB.TextBox txtVirtualWidth 96 | Height = 300 97 | Left = 1548 98 | TabIndex = 3 99 | Top = 504 100 | Width = 2000 101 | End 102 | Begin VB.Label Label11 103 | Alignment = 1 'Right Justify 104 | Caption = "TopScrollBound:" 105 | Height = 264 106 | Left = 0 107 | TabIndex = 12 108 | Top = 2160 109 | Width = 1488 110 | WordWrap = -1 'True 111 | End 112 | Begin VB.Label Label5 113 | Alignment = 1 'Right Justify 114 | Caption = "HScrollBar:" 115 | Height = 228 116 | Left = 36 117 | TabIndex = 18 118 | Top = 3192 119 | Width = 1452 120 | End 121 | Begin VB.Label Label4 122 | Alignment = 1 'Right Justify 123 | Caption = "VScrollBar:" 124 | Height = 228 125 | Left = 36 126 | TabIndex = 16 127 | Top = 2808 128 | Width = 1452 129 | End 130 | Begin VB.Label Label3 131 | Alignment = 1 'Right Justify 132 | Caption = "HScrollValue:" 133 | Height = 264 134 | Left = 0 135 | TabIndex = 10 136 | Top = 1836 137 | Width = 1488 138 | WordWrap = -1 'True 139 | End 140 | Begin VB.Label Label1 141 | Alignment = 1 'Right Justify 142 | Caption = "VirtualHeight:" 143 | Height = 264 144 | Left = 0 145 | TabIndex = 0 146 | Top = 216 147 | Width = 1488 148 | WordWrap = -1 'True 149 | End 150 | Begin VB.Label Label10 151 | Alignment = 1 'Right Justify 152 | Caption = "VScrollValue:" 153 | Height = 264 154 | Left = 0 155 | TabIndex = 8 156 | Top = 1512 157 | Width = 1488 158 | WordWrap = -1 'True 159 | End 160 | Begin VB.Label Label9 161 | Alignment = 1 'Right Justify 162 | Caption = "RightFreeSpace:" 163 | Height = 264 164 | Left = 0 165 | TabIndex = 6 166 | Top = 1188 167 | Width = 1488 168 | WordWrap = -1 'True 169 | End 170 | Begin VB.Label Label7 171 | Alignment = 1 'Right Justify 172 | Caption = "BottomFreeSpace:" 173 | Height = 264 174 | Left = 0 175 | TabIndex = 4 176 | Top = 864 177 | Width = 1488 178 | WordWrap = -1 'True 179 | End 180 | Begin VB.Label Label8 181 | Alignment = 1 'Right Justify 182 | Caption = "VirtualWidth:" 183 | Height = 264 184 | Left = 0 185 | TabIndex = 2 186 | Top = 540 187 | Width = 1488 188 | WordWrap = -1 'True 189 | End 190 | Begin VB.Label Label2 191 | Alignment = 1 'Right Justify 192 | Caption = "BorderStyle:" 193 | Height = 228 194 | Left = 36 195 | TabIndex = 14 196 | Top = 2484 197 | Width = 1452 198 | End 199 | End 200 | Attribute VB_Name = "ptpScrollableContainer" 201 | Attribute VB_GlobalNameSpace = False 202 | Attribute VB_Creatable = True 203 | Attribute VB_PredeclaredId = False 204 | Attribute VB_Exposed = True 205 | Option Explicit 206 | 207 | Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 208 | Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long 209 | 210 | Private Const ES_NUMBER As Long = &H2000& 211 | Private Const GWL_STYLE = (-16) 212 | 213 | Private mLoading As Boolean 214 | 215 | Private Sub cboBorderStyle_Click() 216 | If Not mLoading Then Changed = True 217 | End Sub 218 | 219 | Private Sub cboHScrollBar_Click() 220 | If Not mLoading Then Changed = True 221 | End Sub 222 | 223 | Private Sub cboVScrollBar_Click() 224 | If Not mLoading Then Changed = True 225 | End Sub 226 | 227 | Private Sub chkAutoScrollOnFocus_Click() 228 | If Not mLoading Then Changed = True 229 | End Sub 230 | 231 | Private Sub PropertyPage_ApplyChanges() 232 | Dim iSng As Single 233 | Dim iStr As String 234 | 235 | On Error Resume Next 236 | iSng = -1 237 | iStr = Trim(txtVirtualHeight.Text) 238 | If iStr = "" Then iStr = "0" 239 | iSng = CSng(iStr) 240 | If iSng <> -1 Then 241 | SelectedControls(0).VirtualHeight = iSng 242 | End If 243 | 244 | iSng = -1 245 | iStr = Trim(txtVirtualWidth.Text) 246 | If iStr = "" Then iStr = "0" 247 | iSng = CSng(iStr) 248 | If iSng <> -1 Then 249 | SelectedControls(0).VirtualWidth = iSng 250 | End If 251 | 252 | iSng = -1 253 | iStr = Trim(txtBottomFreeSpace.Text) 254 | If iStr = "" Then iStr = "0" 255 | iSng = CSng(iStr) 256 | If iSng <> -1 Then 257 | SelectedControls(0).BottomFreeSpace = iSng 258 | End If 259 | 260 | iSng = -1 261 | iStr = Trim(txtRightFreeSpace.Text) 262 | If iStr = "" Then iStr = "0" 263 | iSng = CSng(iStr) 264 | If iSng <> -1 Then 265 | SelectedControls(0).RightFreeSpace = iSng 266 | End If 267 | 268 | iSng = -1 269 | iStr = Trim(txtVScrollValue.Text) 270 | If iStr = "" Then iStr = "0" 271 | iSng = CSng(iStr) 272 | If iSng <> -1 Then 273 | SelectedControls(0).VScrollValue = iSng 274 | End If 275 | 276 | iSng = -1 277 | iStr = Trim(txtHScrollValue.Text) 278 | If iStr = "" Then iStr = "0" 279 | iSng = CSng(iStr) 280 | If iSng <> -1 Then 281 | SelectedControls(0).HScrollValue = iSng 282 | End If 283 | 284 | iSng = -1 285 | iStr = Trim(txtTopScrollBound.Text) 286 | If iStr = "" Then iStr = "0" 287 | iSng = CSng(iStr) 288 | If iSng <> -1 Then 289 | SelectedControls(0).TopScrollBound = iSng 290 | End If 291 | 292 | If cboBorderStyle.ListIndex > -1 Then 293 | SelectedControls(0).BorderStyle = cboBorderStyle.ItemData(cboBorderStyle.ListIndex) 294 | End If 295 | If cboVScrollBar.ListIndex > -1 Then 296 | SelectedControls(0).VScrollBar = cboVScrollBar.ItemData(cboVScrollBar.ListIndex) 297 | End If 298 | If cboHScrollBar.ListIndex > -1 Then 299 | SelectedControls(0).HScrollBar = cboHScrollBar.ItemData(cboHScrollBar.ListIndex) 300 | End If 301 | 302 | SelectedControls(0).AutoScrollOnFocus = CBool(chkAutoScrollOnFocus.Value) 303 | End Sub 304 | 305 | Private Sub PropertyPage_SelectionChanged() 306 | Dim iParent As Object 307 | Dim iCtl As Control 308 | Dim iFont As Object 309 | 310 | SetTextBoxNumeric txtVirtualHeight 311 | SetTextBoxNumeric txtVirtualWidth 312 | SetTextBoxNumeric txtBottomFreeSpace 313 | SetTextBoxNumeric txtRightFreeSpace 314 | SetTextBoxNumeric txtVScrollValue 315 | SetTextBoxNumeric txtHScrollValue 316 | SetTextBoxNumeric txtTopScrollBound 317 | 318 | mLoading = True 319 | LoadSettingsInCombos 320 | txtVirtualHeight.Text = SelectedControls(0).VirtualHeight 321 | txtVirtualWidth.Text = SelectedControls(0).VirtualWidth 322 | txtBottomFreeSpace.Text = SelectedControls(0).BottomFreeSpace 323 | txtRightFreeSpace.Text = SelectedControls(0).RightFreeSpace 324 | txtVScrollValue.Text = SelectedControls(0).VScrollValue 325 | txtHScrollValue.Text = SelectedControls(0).HScrollValue 326 | txtTopScrollBound.Text = SelectedControls(0).TopScrollBound 327 | SelectInComboByItemData cboBorderStyle, SelectedControls(0).BorderStyle 328 | SelectInComboByItemData cboVScrollBar, SelectedControls(0).VScrollBar 329 | SelectInComboByItemData cboHScrollBar, SelectedControls(0).HScrollBar 330 | chkAutoScrollOnFocus.Value = Abs(CLng(SelectedControls(0).AutoScrollOnFocus)) 331 | mLoading = False 332 | End Sub 333 | 334 | Private Sub txtVirtualWidth_Change() 335 | If Not mLoading Then Changed = True 336 | End Sub 337 | 338 | Private Sub txtVirtualWidth_GotFocus() 339 | SelectTxtOnGotFocus txtVirtualWidth 340 | End Sub 341 | 342 | 343 | Private Sub txtVirtualHeight_Change() 344 | If Not mLoading Then 345 | Static PrevValue As Single 346 | 347 | Changed = True 348 | If SelectedControls(0).TopScrollBound = SelectedControls(0).VirtualHeight Then 349 | If (Val(txtTopScrollBound.Text) = SelectedControls(0).TopScrollBound) Or (Val(txtTopScrollBound.Text) = PrevValue) Then 350 | txtTopScrollBound.Text = txtVirtualHeight.Text 351 | End If 352 | End If 353 | PrevValue = Val(txtVirtualHeight.Text) 354 | End If 355 | End Sub 356 | 357 | Private Sub txtVirtualHeight_GotFocus() 358 | SelectTxtOnGotFocus txtVirtualHeight 359 | End Sub 360 | 361 | 362 | Private Sub txtRightFreeSpace_Change() 363 | If Not mLoading Then Changed = True 364 | End Sub 365 | 366 | Private Sub txtRightFreeSpace_GotFocus() 367 | SelectTxtOnGotFocus txtRightFreeSpace 368 | End Sub 369 | 370 | 371 | Private Sub txtBottomFreeSpace_Change() 372 | If Not mLoading Then Changed = True 373 | End Sub 374 | 375 | Private Sub txtBottomFreeSpace_GotFocus() 376 | SelectTxtOnGotFocus txtBottomFreeSpace 377 | End Sub 378 | 379 | 380 | Private Sub txtVScrollValue_Change() 381 | If Not mLoading Then Changed = True 382 | End Sub 383 | 384 | Private Sub txtVScrollValue_GotFocus() 385 | SelectTxtOnGotFocus txtVScrollValue 386 | End Sub 387 | 388 | 389 | Private Sub txtHScrollValue_Change() 390 | If Not mLoading Then Changed = True 391 | End Sub 392 | 393 | Private Sub txtHScrollValue_GotFocus() 394 | SelectTxtOnGotFocus txtHScrollValue 395 | End Sub 396 | 397 | 398 | Private Sub LoadSettingsInCombos() 399 | Dim iLi As Long 400 | 401 | ' BorderStyle 402 | iLi = cboBorderStyle.ListIndex 403 | cboBorderStyle.Clear 404 | cboBorderStyle.AddItem vxEBSNone & " - vxEBSNone": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSNone 405 | cboBorderStyle.AddItem vxEBSFlat1Pix & " - vxEBSFlat1Pix": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSFlat1Pix 406 | cboBorderStyle.AddItem vxEBSFlat2Pix & " - vxEBSFlat2Pix": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSFlat2Pix 407 | cboBorderStyle.AddItem vxEBSSunken2Pix & " - vxEBSSunken2Pix": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSSunken2Pix 408 | cboBorderStyle.AddItem vxEBSRaised2Pix & " - vxEBSRaised2Pix": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSRaised2Pix 409 | cboBorderStyle.AddItem vxEBSEtched2Pix & " - vxEBSEtched2Pix": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSEtched2Pix 410 | cboBorderStyle.AddItem vxEBSSunkenOuter1Pix & " - vxEBSSunkenOuter1Pix": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSSunkenOuter1Pix 411 | cboBorderStyle.AddItem vxEBSSunkenInner1Pix & " - vxEBSSunkenInner1Pix": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSSunkenInner1Pix 412 | cboBorderStyle.AddItem vxEBSRaisedOuter1Pix & " - vxEBSRaisedOuter1Pix": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSRaisedOuter1Pix 413 | cboBorderStyle.AddItem vxEBSRaisedInner1Pix & " - vxEBSRaisedInner1Pix": cboBorderStyle.ItemData(cboBorderStyle.NewIndex) = vxEBSRaisedInner1Pix 414 | If iLi > -1 Then 415 | cboBorderStyle.ListIndex = iLi 416 | End If 417 | 418 | ' VScrollBar 419 | iLi = cboVScrollBar.ListIndex 420 | cboVScrollBar.Clear 421 | cboVScrollBar.AddItem vxScrollBarHide & " - vxScrollBarHide": cboVScrollBar.ItemData(cboVScrollBar.NewIndex) = vxScrollBarHide 422 | cboVScrollBar.AddItem vxScrollBarShow & " - vxScrollBarShow": cboVScrollBar.ItemData(cboVScrollBar.NewIndex) = vxScrollBarShow 423 | cboVScrollBar.AddItem vxScrollBarAuto & " - vxScrollBarAuto": cboVScrollBar.ItemData(cboVScrollBar.NewIndex) = vxScrollBarAuto 424 | If iLi > -1 Then 425 | cboVScrollBar.ListIndex = iLi 426 | End If 427 | 428 | ' HScrollBar 429 | iLi = cboHScrollBar.ListIndex 430 | cboHScrollBar.Clear 431 | cboHScrollBar.AddItem vxScrollBarHide & " - vxScrollBarHide": cboHScrollBar.ItemData(cboHScrollBar.NewIndex) = vxScrollBarHide 432 | cboHScrollBar.AddItem vxScrollBarShow & " - vxScrollBarShow": cboHScrollBar.ItemData(cboHScrollBar.NewIndex) = vxScrollBarShow 433 | cboHScrollBar.AddItem vxScrollBarAuto & " - vxScrollBarAuto": cboHScrollBar.ItemData(cboHScrollBar.NewIndex) = vxScrollBarAuto 434 | If iLi > -1 Then 435 | cboHScrollBar.ListIndex = iLi 436 | End If 437 | 438 | End Sub 439 | 440 | Private Sub SetTextBoxNumeric(nTxt As Control) 441 | SetWindowLong nTxt.hWnd, GWL_STYLE, GetWindowLong(nTxt.hWnd, GWL_STYLE) Or ES_NUMBER 442 | End Sub 443 | 444 | Private Sub SelectInComboByItemData(nCombo As Control, nItemData As Long) 445 | Dim c As Long 446 | 447 | For c = 0 To nCombo.ListCount - 1 448 | If nCombo.ItemData(c) = nItemData Then 449 | nCombo.ListIndex = c 450 | Exit Sub 451 | End If 452 | Next c 453 | End Sub 454 | 455 | Private Sub SelectTxtOnGotFocus(nTextBox As Control) 456 | If nTextBox.SelStart = 0 Then 457 | If nTextBox.SelLength = 0 Then 458 | nTextBox.SelLength = Len(nTextBox.Text) 459 | End If 460 | End If 461 | End Sub 462 | 463 | -------------------------------------------------------------------------------- /control-source/subclass/cIBSSubclass.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "IBSSubclass" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Public Function MsgResponse(ByVal hWnd As Long, ByVal iMsg As Long) As Long 17 | ' 18 | End Function 19 | 20 | Function WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, ByRef wParam As Long, ByRef lParam As Long, ByRef bConsume As Boolean) As Long 21 | Attribute WindowProc.VB_Description = "Raised whenever a message you have subclassed is sent." 22 | ' 23 | End Function 24 | 25 | Public Sub UnsubclassIt() 26 | 27 | End Sub 28 | -------------------------------------------------------------------------------- /control-source/subclass/mBSPropsDB.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "mBSPropsDB" 2 | Option Explicit 3 | 4 | Public gWinPropsDB As New Collection 5 | 6 | Public Function MySetProp(nHwnd As Long, nPropertyName As String, nData As Long) As Long 7 | 8 | On Error Resume Next 9 | Err.Clear 10 | gWinPropsDB.Add nData, CStr(nHwnd) & "|" & nPropertyName 11 | If Err.Number = 457 Then 12 | On Error GoTo ErrorExit: 13 | gWinPropsDB.Remove CStr(nHwnd) & "|" & nPropertyName 14 | gWinPropsDB.Add nData, CStr(nHwnd) & "|" & nPropertyName 15 | End If 16 | 'Debug.Print gWinPropsDB.count 17 | MySetProp = 1 18 | Exit Function 19 | 20 | ErrorExit: 21 | MySetProp = 0 22 | Err.Clear 23 | End Function 24 | 25 | Public Function MyGetProp(nHwnd As Long, nPropertyName As String) As Long 26 | 27 | On Error GoTo ErrorExit: 28 | MyGetProp = gWinPropsDB(CStr(nHwnd) & "|" & nPropertyName) 29 | Exit Function 30 | 31 | ErrorExit: 32 | MyGetProp = 0 33 | 'Debug.Print "Error MyGetProp, hWnd" & nHwnd & ", PropertyName: " & nPropertyName 34 | Err.Clear 35 | End Function 36 | 37 | Public Function MyRemoveProp(nHwnd As Long, nPropertyName As String) As Long 38 | 39 | On Error Resume Next 40 | MyRemoveProp = gWinPropsDB(CStr(nHwnd) & "|" & nPropertyName) 41 | On Error GoTo ErrorExit: 42 | gWinPropsDB.Remove CStr(nHwnd) & "|" & nPropertyName 43 | Exit Function 44 | 45 | ErrorExit: 46 | MyRemoveProp = 0 47 | Err.Clear 48 | End Function 49 | 50 | -------------------------------------------------------------------------------- /control-source/subclass/mBSSubclass.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ScrollableContainer/7e3f80a3171e11940aa9b1ee6f273d6884902a75/control-source/subclass/mBSSubclass.bas -------------------------------------------------------------------------------- /ocx/ScllCnt1 Register (run as Admin).bat: -------------------------------------------------------------------------------- 1 | RegSvr32.exe "%~dp0ScllCnt1.ocx" -------------------------------------------------------------------------------- /ocx/ScllCnt1 Unregister (run as Admin).bat: -------------------------------------------------------------------------------- 1 | RegSvr32.exe "%~dp0ScllCnt1.ocx" /u -------------------------------------------------------------------------------- /ocx/ScllCnt1.ocx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ScrollableContainer/7e3f80a3171e11940aa9b1ee6f273d6884902a75/ocx/ScllCnt1.ocx -------------------------------------------------------------------------------- /test compiled ocx/Form1.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form Form1 3 | BorderStyle = 1 'Fixed Single 4 | Caption = "Form1" 5 | ClientHeight = 7272 6 | ClientLeft = 2604 7 | ClientTop = 1644 8 | ClientWidth = 6540 9 | BeginProperty Font 10 | Name = "Tahoma" 11 | Size = 7.8 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | MaxButton = 0 'False 20 | MinButton = 0 'False 21 | ScaleHeight = 7272 22 | ScaleWidth = 6540 23 | Begin ScllContainer.ScrollableContainer ScrollableContainer1 24 | Height = 3972 25 | Left = 288 26 | TabIndex = 4 27 | Top = 1188 28 | Width = 5952 29 | _ExtentX = 10499 30 | _ExtentY = 7006 31 | SavedVScrollMax = 329 32 | SavedVirtualHeight= 3948 33 | SavedHScrollMax = 494 34 | SavedVirtualWidth= 5928 35 | Begin VB.TextBox txtData 36 | Height = 336 37 | Index = 15 38 | Left = 1512 39 | TabIndex = 36 40 | Top = 6592 41 | Width = 3828 42 | End 43 | Begin VB.TextBox txtData 44 | Height = 336 45 | Index = 14 46 | Left = 1512 47 | TabIndex = 34 48 | Top = 6152 49 | Width = 3828 50 | End 51 | Begin VB.TextBox txtData 52 | Height = 336 53 | Index = 13 54 | Left = 1512 55 | TabIndex = 32 56 | Top = 5728 57 | Width = 3828 58 | End 59 | Begin VB.TextBox txtData 60 | Height = 336 61 | Index = 12 62 | Left = 1512 63 | TabIndex = 30 64 | Top = 5296 65 | Width = 3828 66 | End 67 | Begin VB.TextBox txtData 68 | Height = 336 69 | Index = 11 70 | Left = 1512 71 | TabIndex = 28 72 | Top = 4888 73 | Width = 3828 74 | End 75 | Begin VB.TextBox txtData 76 | Height = 336 77 | Index = 10 78 | Left = 1512 79 | TabIndex = 26 80 | Top = 4456 81 | Width = 3828 82 | End 83 | Begin VB.TextBox txtData 84 | Height = 336 85 | Index = 9 86 | Left = 1512 87 | TabIndex = 24 88 | Top = 4024 89 | Width = 3828 90 | End 91 | Begin VB.TextBox txtData 92 | Height = 336 93 | Index = 7 94 | Left = 1512 95 | TabIndex = 20 96 | Top = 3160 97 | Width = 3828 98 | End 99 | Begin VB.TextBox txtData 100 | Height = 336 101 | Index = 6 102 | Left = 1512 103 | TabIndex = 18 104 | Top = 2728 105 | Width = 3828 106 | End 107 | Begin VB.TextBox txtData 108 | Height = 336 109 | Index = 5 110 | Left = 1512 111 | TabIndex = 16 112 | Top = 2296 113 | Width = 3828 114 | End 115 | Begin VB.TextBox txtData 116 | Height = 336 117 | Index = 4 118 | Left = 1512 119 | TabIndex = 14 120 | Top = 1864 121 | Width = 3828 122 | End 123 | Begin VB.TextBox txtData 124 | Height = 336 125 | Index = 3 126 | Left = 1512 127 | TabIndex = 12 128 | Top = 1468 129 | Width = 3828 130 | End 131 | Begin VB.TextBox txtData 132 | Height = 336 133 | Index = 2 134 | Left = 1512 135 | TabIndex = 10 136 | Top = 1036 137 | Width = 3828 138 | End 139 | Begin VB.TextBox txtData 140 | Height = 336 141 | Index = 1 142 | Left = 1512 143 | TabIndex = 8 144 | Top = 604 145 | Width = 3828 146 | End 147 | Begin VB.TextBox txtData 148 | Height = 336 149 | Index = 0 150 | Left = 1512 151 | TabIndex = 6 152 | Top = 172 153 | Width = 3828 154 | End 155 | Begin VB.TextBox txtData 156 | Height = 336 157 | Index = 8 158 | Left = 1512 159 | TabIndex = 22 160 | Top = 3592 161 | Width = 3828 162 | End 163 | Begin VB.Label lblData 164 | Caption = "Enter data 16:" 165 | Height = 300 166 | Index = 15 167 | Left = 288 168 | TabIndex = 35 169 | Top = 6628 170 | Width = 1128 171 | End 172 | Begin VB.Label lblData 173 | Caption = "Enter data 15:" 174 | Height = 300 175 | Index = 14 176 | Left = 288 177 | TabIndex = 33 178 | Top = 6192 179 | Width = 1128 180 | End 181 | Begin VB.Label lblData 182 | Caption = "Enter data 14:" 183 | Height = 300 184 | Index = 13 185 | Left = 288 186 | TabIndex = 31 187 | Top = 5760 188 | Width = 1128 189 | End 190 | Begin VB.Label lblData 191 | Caption = "Enter data 13:" 192 | Height = 300 193 | Index = 12 194 | Left = 288 195 | TabIndex = 29 196 | Top = 5328 197 | Width = 1128 198 | End 199 | Begin VB.Label lblData 200 | Caption = "Enter data 12:" 201 | Height = 300 202 | Index = 11 203 | Left = 288 204 | TabIndex = 27 205 | Top = 4920 206 | Width = 1128 207 | End 208 | Begin VB.Label lblData 209 | Caption = "Enter data 11:" 210 | Height = 300 211 | Index = 10 212 | Left = 288 213 | TabIndex = 25 214 | Top = 4488 215 | Width = 1128 216 | End 217 | Begin VB.Label lblData 218 | Caption = "Enter data 10:" 219 | Height = 300 220 | Index = 9 221 | Left = 288 222 | TabIndex = 23 223 | Top = 4056 224 | Width = 1128 225 | End 226 | Begin VB.Label lblData 227 | Caption = "Enter data 8:" 228 | Height = 300 229 | Index = 7 230 | Left = 288 231 | TabIndex = 19 232 | Top = 3192 233 | Width = 1128 234 | End 235 | Begin VB.Label lblData 236 | Caption = "Enter data 7:" 237 | Height = 300 238 | Index = 6 239 | Left = 288 240 | TabIndex = 17 241 | Top = 2760 242 | Width = 1128 243 | End 244 | Begin VB.Label lblData 245 | Caption = "Enter data 6:" 246 | Height = 300 247 | Index = 5 248 | Left = 288 249 | TabIndex = 15 250 | Top = 2328 251 | Width = 1128 252 | End 253 | Begin VB.Label lblData 254 | Caption = "Enter data 5:" 255 | Height = 300 256 | Index = 4 257 | Left = 288 258 | TabIndex = 13 259 | Top = 1896 260 | Width = 1128 261 | End 262 | Begin VB.Label lblData 263 | Caption = "Enter data 4:" 264 | Height = 300 265 | Index = 3 266 | Left = 288 267 | TabIndex = 11 268 | Top = 1500 269 | Width = 1128 270 | End 271 | Begin VB.Label lblData 272 | Caption = "Enter data 3:" 273 | Height = 300 274 | Index = 2 275 | Left = 288 276 | TabIndex = 9 277 | Top = 1068 278 | Width = 1128 279 | End 280 | Begin VB.Label lblData 281 | Caption = "Enter data 2:" 282 | Height = 300 283 | Index = 1 284 | Left = 288 285 | TabIndex = 7 286 | Top = 636 287 | Width = 1128 288 | End 289 | Begin VB.Label lblData 290 | Caption = "Enter data 1:" 291 | Height = 300 292 | Index = 0 293 | Left = 288 294 | TabIndex = 5 295 | Top = 204 296 | Width = 1128 297 | End 298 | Begin VB.Label lblData 299 | Caption = "Enter data 9:" 300 | Height = 300 301 | Index = 8 302 | Left = 288 303 | TabIndex = 21 304 | Top = 3624 305 | Width = 1128 306 | End 307 | End 308 | Begin VB.Label Label5 309 | Caption = "* Manifest the program for Visual Styles. The scrollbar(s) will show up with the right colors when the program is manifested." 310 | Height = 408 311 | Left = 288 312 | TabIndex = 37 313 | Top = 6660 314 | Width = 5736 315 | End 316 | Begin VB.Label Label4 317 | Caption = "* Properties may lose their values if you use the control in source code (while making modifications like adding controls)." 318 | Height = 408 319 | Left = 288 320 | TabIndex = 3 321 | Top = 6156 322 | Width = 5736 323 | End 324 | Begin VB.Label Label3 325 | Caption = "* At design time, use VScrollValue and HScrollValue properties to move inside the virtual space of the control." 326 | Height = 408 327 | Left = 288 328 | TabIndex = 2 329 | Top = 5652 330 | Width = 5736 331 | End 332 | Begin VB.Label Label2 333 | Caption = "* It can have different borders or not border at all (check BorderStyle property)." 334 | Height = 264 335 | Left = 288 336 | TabIndex = 1 337 | Top = 5328 338 | Width = 5736 339 | End 340 | Begin VB.Label Label1 341 | Alignment = 2 'Center 342 | Caption = "The ScrollableContainer can be used when the form space is not enough for holding all the controls." 343 | BeginProperty Font 344 | Name = "Tahoma" 345 | Size = 12 346 | Charset = 0 347 | Weight = 400 348 | Underline = 0 'False 349 | Italic = 0 'False 350 | Strikethrough = 0 'False 351 | EndProperty 352 | Height = 696 353 | Left = 252 354 | TabIndex = 0 355 | Top = 180 356 | Width = 5916 357 | End 358 | End 359 | Attribute VB_Name = "Form1" 360 | Attribute VB_GlobalNameSpace = False 361 | Attribute VB_Creatable = False 362 | Attribute VB_PredeclaredId = True 363 | Attribute VB_Exposed = False 364 | Option Explicit 365 | 366 | -------------------------------------------------------------------------------- /test compiled ocx/Test_ScrollableContainer.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\SysWow64\stdole2.tlb#OLE Automation 3 | Object={E938552A-A328-4771-A199-96E9E3FECC3A}#1.0#0; ScllCnt1.ocx 4 | Form=Form1.frm 5 | Startup="Form1" 6 | HelpFile="" 7 | Command32="" 8 | Name="Test_ScrollableContainer" 9 | HelpContextID="0" 10 | CompatibleMode="0" 11 | MajorVer=1 12 | MinorVer=0 13 | RevisionVer=0 14 | AutoIncrementVer=0 15 | ServerSupportFiles=0 16 | CompilationType=0 17 | OptimizationType=0 18 | FavorPentiumPro(tm)=0 19 | CodeViewDebugInfo=0 20 | NoAliasing=0 21 | BoundsCheck=0 22 | OverflowCheck=0 23 | FlPointCheck=0 24 | FDIVCheck=0 25 | UnroundedFP=0 26 | StartMode=0 27 | Unattended=0 28 | Retained=0 29 | ThreadPerObject=0 30 | MaxNumberOfThreads=1 31 | -------------------------------------------------------------------------------- /test in source code/Form1.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Object = "*\A..\control-source\ScrollableContainer.vbp" 3 | Begin VB.Form Form1 4 | BorderStyle = 1 'Fixed Single 5 | Caption = "Form1" 6 | ClientHeight = 7272 7 | ClientLeft = 2604 8 | ClientTop = 1644 9 | ClientWidth = 6540 10 | BeginProperty Font 11 | Name = "Tahoma" 12 | Size = 7.8 13 | Charset = 0 14 | Weight = 400 15 | Underline = 0 'False 16 | Italic = 0 'False 17 | Strikethrough = 0 'False 18 | EndProperty 19 | LinkTopic = "Form1" 20 | MaxButton = 0 'False 21 | MinButton = 0 'False 22 | ScaleHeight = 7272 23 | ScaleWidth = 6540 24 | Begin ScllContainer.ScrollableContainer ScrollableContainer2 25 | Height = 900 26 | Left = 6240 27 | TabIndex = 38 28 | Top = 5940 29 | Width = 900 30 | _ExtentX = 1588 31 | _ExtentY = 1588 32 | SavedVScrollMax = 52 33 | SavedVirtualHeight= 624 34 | SavedHScrollMax = 52 35 | SavedVirtualWidth= 624 36 | End 37 | Begin ScllContainer.ScrollableContainer ScrollableContainer1 38 | Height = 3972 39 | Left = 288 40 | TabIndex = 4 41 | Top = 1188 42 | Width = 5952 43 | _ExtentX = 10499 44 | _ExtentY = 7006 45 | SavedVScrollMax = 294 46 | SavedVirtualHeight= 7228 47 | SavedHScrollMax = 473 48 | SavedVirtualWidth= 5676 49 | Begin VB.TextBox txtData 50 | Height = 336 51 | Index = 15 52 | Left = 1512 53 | TabIndex = 36 54 | Top = 6592 55 | Width = 3828 56 | End 57 | Begin VB.TextBox txtData 58 | Height = 336 59 | Index = 14 60 | Left = 1512 61 | TabIndex = 34 62 | Top = 6152 63 | Width = 3828 64 | End 65 | Begin VB.TextBox txtData 66 | Height = 336 67 | Index = 13 68 | Left = 1512 69 | TabIndex = 32 70 | Top = 5728 71 | Width = 3828 72 | End 73 | Begin VB.TextBox txtData 74 | Height = 336 75 | Index = 12 76 | Left = 1512 77 | TabIndex = 30 78 | Top = 5296 79 | Width = 3828 80 | End 81 | Begin VB.TextBox txtData 82 | Height = 336 83 | Index = 11 84 | Left = 1512 85 | TabIndex = 28 86 | Top = 4888 87 | Width = 3828 88 | End 89 | Begin VB.TextBox txtData 90 | Height = 336 91 | Index = 10 92 | Left = 1512 93 | TabIndex = 26 94 | Top = 4456 95 | Width = 3828 96 | End 97 | Begin VB.TextBox txtData 98 | Height = 336 99 | Index = 9 100 | Left = 1512 101 | TabIndex = 24 102 | Top = 4024 103 | Width = 3828 104 | End 105 | Begin VB.TextBox txtData 106 | Height = 336 107 | Index = 7 108 | Left = 1512 109 | TabIndex = 20 110 | Top = 3160 111 | Width = 3828 112 | End 113 | Begin VB.TextBox txtData 114 | Height = 336 115 | Index = 6 116 | Left = 1512 117 | TabIndex = 18 118 | Top = 2728 119 | Width = 3828 120 | End 121 | Begin VB.TextBox txtData 122 | Height = 336 123 | Index = 5 124 | Left = 1512 125 | TabIndex = 16 126 | Top = 2296 127 | Width = 3828 128 | End 129 | Begin VB.TextBox txtData 130 | Height = 336 131 | Index = 4 132 | Left = 1512 133 | TabIndex = 14 134 | Top = 1864 135 | Width = 3828 136 | End 137 | Begin VB.TextBox txtData 138 | Height = 336 139 | Index = 3 140 | Left = 1512 141 | TabIndex = 12 142 | Top = 1468 143 | Width = 3828 144 | End 145 | Begin VB.TextBox txtData 146 | Height = 336 147 | Index = 2 148 | Left = 1512 149 | TabIndex = 10 150 | Top = 1036 151 | Width = 3828 152 | End 153 | Begin VB.TextBox txtData 154 | Height = 336 155 | Index = 1 156 | Left = 1512 157 | TabIndex = 8 158 | Top = 604 159 | Width = 3828 160 | End 161 | Begin VB.TextBox txtData 162 | Height = 336 163 | Index = 0 164 | Left = 1512 165 | TabIndex = 6 166 | Top = 172 167 | Width = 3828 168 | End 169 | Begin VB.TextBox txtData 170 | Height = 336 171 | Index = 8 172 | Left = 1512 173 | TabIndex = 22 174 | Top = 3592 175 | Width = 3828 176 | End 177 | Begin VB.Label lblData 178 | Caption = "Enter data 16:" 179 | Height = 300 180 | Index = 15 181 | Left = 288 182 | TabIndex = 35 183 | Top = 6628 184 | Width = 1128 185 | End 186 | Begin VB.Label lblData 187 | Caption = "Enter data 15:" 188 | Height = 300 189 | Index = 14 190 | Left = 288 191 | TabIndex = 33 192 | Top = 6192 193 | Width = 1128 194 | End 195 | Begin VB.Label lblData 196 | Caption = "Enter data 14:" 197 | Height = 300 198 | Index = 13 199 | Left = 288 200 | TabIndex = 31 201 | Top = 5760 202 | Width = 1128 203 | End 204 | Begin VB.Label lblData 205 | Caption = "Enter data 13:" 206 | Height = 300 207 | Index = 12 208 | Left = 288 209 | TabIndex = 29 210 | Top = 5328 211 | Width = 1128 212 | End 213 | Begin VB.Label lblData 214 | Caption = "Enter data 12:" 215 | Height = 300 216 | Index = 11 217 | Left = 288 218 | TabIndex = 27 219 | Top = 4920 220 | Width = 1128 221 | End 222 | Begin VB.Label lblData 223 | Caption = "Enter data 11:" 224 | Height = 300 225 | Index = 10 226 | Left = 288 227 | TabIndex = 25 228 | Top = 4488 229 | Width = 1128 230 | End 231 | Begin VB.Label lblData 232 | Caption = "Enter data 10:" 233 | Height = 300 234 | Index = 9 235 | Left = 288 236 | TabIndex = 23 237 | Top = 4056 238 | Width = 1128 239 | End 240 | Begin VB.Label lblData 241 | Caption = "Enter data 8:" 242 | Height = 300 243 | Index = 7 244 | Left = 288 245 | TabIndex = 19 246 | Top = 3192 247 | Width = 1128 248 | End 249 | Begin VB.Label lblData 250 | Caption = "Enter data 7:" 251 | Height = 300 252 | Index = 6 253 | Left = 288 254 | TabIndex = 17 255 | Top = 2760 256 | Width = 1128 257 | End 258 | Begin VB.Label lblData 259 | Caption = "Enter data 6:" 260 | Height = 300 261 | Index = 5 262 | Left = 288 263 | TabIndex = 15 264 | Top = 2328 265 | Width = 1128 266 | End 267 | Begin VB.Label lblData 268 | Caption = "Enter data 5:" 269 | Height = 300 270 | Index = 4 271 | Left = 288 272 | TabIndex = 13 273 | Top = 1896 274 | Width = 1128 275 | End 276 | Begin VB.Label lblData 277 | Caption = "Enter data 4:" 278 | Height = 300 279 | Index = 3 280 | Left = 288 281 | TabIndex = 11 282 | Top = 1500 283 | Width = 1128 284 | End 285 | Begin VB.Label lblData 286 | Caption = "Enter data 3:" 287 | Height = 300 288 | Index = 2 289 | Left = 288 290 | TabIndex = 9 291 | Top = 1068 292 | Width = 1128 293 | End 294 | Begin VB.Label lblData 295 | Caption = "Enter data 2:" 296 | Height = 300 297 | Index = 1 298 | Left = 288 299 | TabIndex = 7 300 | Top = 636 301 | Width = 1128 302 | End 303 | Begin VB.Label lblData 304 | Caption = "Enter data 1:" 305 | Height = 300 306 | Index = 0 307 | Left = 288 308 | TabIndex = 5 309 | Top = 204 310 | Width = 1128 311 | End 312 | Begin VB.Label lblData 313 | Caption = "Enter data 9:" 314 | Height = 300 315 | Index = 8 316 | Left = 288 317 | TabIndex = 21 318 | Top = 3624 319 | Width = 1128 320 | End 321 | End 322 | Begin VB.Label Label5 323 | Caption = "* Manifest the program for Visual Styles. The scrollbar(s) will show up with the right colors when the program is manifested." 324 | Height = 408 325 | Left = 288 326 | TabIndex = 37 327 | Top = 6660 328 | Width = 5736 329 | End 330 | Begin VB.Label Label4 331 | Caption = "* Properties may lose their values if you use the control in source code (while making modifications like adding controls)." 332 | Height = 408 333 | Left = 288 334 | TabIndex = 3 335 | Top = 6156 336 | Width = 5736 337 | End 338 | Begin VB.Label Label3 339 | Caption = "* At design time, use VScrollValue and HScrollValue properties to move inside the virtual space of the control." 340 | Height = 408 341 | Left = 288 342 | TabIndex = 2 343 | Top = 5652 344 | Width = 5736 345 | End 346 | Begin VB.Label Label2 347 | Caption = "* It can have different borders or not border at all (check BorderStyle property)." 348 | Height = 264 349 | Left = 288 350 | TabIndex = 1 351 | Top = 5328 352 | Width = 5736 353 | End 354 | Begin VB.Label Label1 355 | Alignment = 2 'Center 356 | Caption = "The ScrollableContainer can be used when the form space is not enough for holding all the controls." 357 | BeginProperty Font 358 | Name = "Tahoma" 359 | Size = 12 360 | Charset = 0 361 | Weight = 400 362 | Underline = 0 'False 363 | Italic = 0 'False 364 | Strikethrough = 0 'False 365 | EndProperty 366 | Height = 696 367 | Left = 252 368 | TabIndex = 0 369 | Top = 180 370 | Width = 5916 371 | End 372 | End 373 | Attribute VB_Name = "Form1" 374 | Attribute VB_GlobalNameSpace = False 375 | Attribute VB_Creatable = False 376 | Attribute VB_PredeclaredId = True 377 | Attribute VB_Exposed = False 378 | Option Explicit 379 | 380 | -------------------------------------------------------------------------------- /test in source code/Test_ScrollableContainer.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\SysWow64\stdole2.tlb#OLE Automation 3 | Object=*\A..\control-source\ScrollableContainer.vbp 4 | Form=Form1.frm 5 | Startup="Form1" 6 | HelpFile="" 7 | Command32="" 8 | Name="Test_ScrollableContainer" 9 | HelpContextID="0" 10 | CompatibleMode="0" 11 | MajorVer=1 12 | MinorVer=0 13 | RevisionVer=0 14 | AutoIncrementVer=0 15 | ServerSupportFiles=0 16 | CompilationType=0 17 | OptimizationType=0 18 | FavorPentiumPro(tm)=0 19 | CodeViewDebugInfo=0 20 | NoAliasing=0 21 | BoundsCheck=0 22 | OverflowCheck=0 23 | FlPointCheck=0 24 | FDIVCheck=0 25 | UnroundedFP=0 26 | StartMode=0 27 | Unattended=0 28 | Retained=0 29 | ThreadPerObject=0 30 | MaxNumberOfThreads=1 31 | --------------------------------------------------------------------------------