home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Mikes_MP3_1935449252005.psc / ctlAutoResize.CTL < prev    next >
Text File  |  2005-09-15  |  17KB  |  418 lines
  1. VERSION 5.00
  2. Begin VB.UserControl ctlAutoResize 
  3.    CanGetFocus     =   0   'False
  4.    ClientHeight    =   720
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   750
  8.    FillStyle       =   0  'Solid
  9.    BeginProperty Font 
  10.       Name            =   "Arial"
  11.       Size            =   9.75
  12.       Charset         =   0
  13.       Weight          =   400
  14.       Underline       =   0   'False
  15.       Italic          =   0   'False
  16.       Strikethrough   =   0   'False
  17.    EndProperty
  18.    InvisibleAtRuntime=   -1  'True
  19.    Picture         =   "ctlAutoResize.ctx":0000
  20.    ScaleHeight     =   720
  21.    ScaleWidth      =   750
  22.    ToolboxBitmap   =   "ctlAutoResize.ctx":2132
  23. End
  24. Attribute VB_Name = "ctlAutoResize"
  25. Attribute VB_GlobalNameSpace = False
  26. Attribute VB_Creatable = True
  27. Attribute VB_PredeclaredId = False
  28. Attribute VB_Exposed = False
  29. Option Explicit
  30. Private Type ControlSettings
  31.     IndexValue                       As Long
  32.     LeftValue                        As Single
  33.     TopValue                         As Single
  34.     WidthValue                       As Single
  35.     HeightValue                      As Single
  36.     FontSizeValue                    As Single
  37. End Type
  38. Private State                    As Boolean
  39. Private FontResize               As Boolean
  40. Private AspectRatio43            As Boolean
  41. Private HM                       As Long
  42. Private WM                       As Long
  43. Private AspectRatioValue43       As Double
  44. Private CtrlTot                  As Long
  45. Private ControlsOnForm()         As ControlSettings
  46. Private ParentWidth              As Single
  47. Private ParentHeight             As Single
  48. Private WithEvents ParentForm    As Form
  49. Attribute ParentForm.VB_VarHelpID = -1
  50. Public Property Get AspectRatioValue() As Double
  51.     On Error GoTo ErrorTrap
  52.     AspectRatioValue = AspectRatioValue43
  53. Exit Property
  54. ErrorTrap:
  55.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  56.        Err.Description & vbNewLine & _
  57.        vbNewLine & _
  58.        "Debug Information:" & vbNewLine & _
  59.        "MidiDateBase.AutoResize.AspectRatioValue" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  60. End Property
  61. Public Property Let AspectRatioValue(ByVal Value As Double)
  62.     On Error GoTo ErrorTrap
  63.     AspectRatioValue43 = Value
  64. Exit Property
  65. ErrorTrap:
  66.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  67.        Err.Description & vbNewLine & _
  68.        vbNewLine & _
  69.        "Debug Information:" & vbNewLine & _
  70.        "MidiDateBase.AutoResize.AspectRatioValue" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  71. End Property
  72. Public Property Get Enabled() As Boolean
  73.     On Error GoTo ErrorTrap
  74.     Enabled = State
  75. Exit Property
  76. ErrorTrap:
  77.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  78.        Err.Description & vbNewLine & _
  79.        vbNewLine & _
  80.        "Debug Information:" & vbNewLine & _
  81.        "MidiDateBase.AutoResize.Enabled" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  82. End Property
  83. Public Property Let Enabled(ByVal Value As Boolean)
  84.     On Error GoTo ErrorTrap
  85.     State = Value
  86. Exit Property
  87. ErrorTrap:
  88.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  89.        Err.Description & vbNewLine & _
  90.        vbNewLine & _
  91.        "Debug Information:" & vbNewLine & _
  92.        "MidiDateBase.AutoResize.Enabled" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  93. End Property
  94. Public Property Get FontResizable() As Boolean
  95.     On Error GoTo ErrorTrap
  96.     FontResizable = FontResize
  97. Exit Property
  98. ErrorTrap:
  99.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  100.        Err.Description & vbNewLine & _
  101.        vbNewLine & _
  102.        "Debug Information:" & vbNewLine & _
  103.        "MidiDateBase.AutoResize.FontResizable" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  104. End Property
  105. Public Property Let FontResizable(ByVal Value As Boolean)
  106.     On Error GoTo ErrorTrap
  107.     FontResize = Value
  108. Exit Property
  109. ErrorTrap:
  110.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  111.        Err.Description & vbNewLine & _
  112.        vbNewLine & _
  113.        "Debug Information:" & vbNewLine & _
  114.        "MidiDateBase.AutoResize.FontResizable" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  115. End Property
  116. Public Property Get HMin() As Long
  117.     On Error GoTo ErrorTrap
  118.     HMin = HM
  119. Exit Property
  120. ErrorTrap:
  121.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  122.        Err.Description & vbNewLine & _
  123.        vbNewLine & _
  124.        "Debug Information:" & vbNewLine & _
  125.        "MidiDateBase.AutoResize.HMin" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  126. End Property
  127. Public Property Let HMin(ByVal Value As Long)
  128.     On Error GoTo ErrorTrap
  129.     HM = Value
  130. Exit Property
  131. ErrorTrap:
  132.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  133.        Err.Description & vbNewLine & _
  134.        vbNewLine & _
  135.        "Debug Information:" & vbNewLine & _
  136.        "MidiDateBase.AutoResize.HMin" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  137. End Property
  138. Public Property Get KeepAspectRatio() As Boolean
  139.     On Error GoTo ErrorTrap
  140.     KeepAspectRatio = AspectRatio43
  141. Exit Property
  142. ErrorTrap:
  143.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  144.        Err.Description & vbNewLine & _
  145.        vbNewLine & _
  146.        "Debug Information:" & vbNewLine & _
  147.        "MidiDateBase.AutoResize.KeepAspectRatio" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  148. End Property
  149. Public Property Let KeepAspectRatio(ByVal Value As Boolean)
  150.     On Error Resume Next
  151.     AspectRatio43 = Value
  152. 'if AspectRation enabled, calculates the AspectRatio Value
  153.     If Value Then
  154.         AspectRatioValue = UserControl.Extender.Parent.Height / UserControl.Extender.Parent.Width
  155.     Else
  156.         AspectRatioValue = 0
  157.     End If
  158.     PropertyChanged "KeepAspectRatio"
  159.     On Error GoTo 0
  160. End Property
  161. Private Sub ParentForm_Load()
  162.     On Error GoTo ErrorTrap
  163.     CtrlTot = 0
  164.     StoreOriginalSettings
  165. Exit Sub
  166. ErrorTrap:
  167.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  168.        Err.Description & vbNewLine & _
  169.        vbNewLine & _
  170.        "Debug Information:" & vbNewLine & _
  171.        "MidiDateBase.AutoResize.ParentForm_Load" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  172. End Sub
  173. Private Sub ParentForm_Resize()
  174.     On Error GoTo ErrorTrap
  175. 'Triggered when the form containing the autoresize control is resized
  176. 'If reduced to icon dont't resize
  177.     If ParentForm.WindowState = 1 Then
  178.         GoTo OneExit
  179.     End If
  180. 'If the autoresize control is disabled don't resize
  181.     If Not Enabled Then
  182.         GoTo OneExit
  183.     End If
  184. 'If form height < than value assigned to HMIN force the parent height to HMIN
  185.     If ParentForm.Height < HMin Then
  186.         ParentForm.Height = HMin
  187.     End If
  188. 'same as above for widtyh
  189.     If ParentForm.Width < WMin Then
  190.         ParentForm.Width = WMin
  191.     End If
  192.     UpdateControls 'Resize the controls on the form
  193. OneExit:
  194. Exit Sub
  195. ErrorTrap:
  196.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  197.        Err.Description & vbNewLine & _
  198.        vbNewLine & _
  199.        "Debug Information:" & vbNewLine & _
  200.        "MidiDateBase.AutoResize.ParentForm_Resize" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  201. End Sub
  202. Private Sub StoreOriginalSettings()
  203. 'This routine runs just once (when the form is loaded)
  204. Dim I         As Integer
  205. Dim Controllo As Control
  206.     On Error Resume Next
  207. 'If not running exit
  208.     If Not Ambient.UserMode Then
  209.         GoTo TwoExit
  210.     End If
  211.     ParentWidth = ParentForm.ScaleWidth 'save the original size of the form
  212.     ParentHeight = ParentForm.ScaleHeight
  213.     For I = 0 To ParentForm.Controls.Count - 1  'Loop to check all the controls on the form
  214.         Set Controllo = ParentForm.Controls(I)
  215.         If TypeName(Controllo) = "StatusBar" Then 'if the control is a status bar
  216. 'it will be resized only if the Align property is set to none
  217.             If Controllo.Align > 0 Then
  218.                 GoTo Skip
  219.             End If
  220. 'You can add here other controls that have similar properties
  221.         End If
  222. 'The Tag property set to NO prevent the control from resizing
  223.         If Controllo.Tag = "NO" Then
  224.             GoTo Skip
  225.         End If
  226.         CtrlTot = CtrlTot + 1   'Variable to keep the number of controls to resize
  227.         ReDim Preserve ControlsOnForm(1 To CtrlTot)
  228. 'Redim the array containing the data needed for resizing
  229.         With ControlsOnForm(CtrlTot)
  230.             .IndexValue = I 'save the index of the control
  231.             If TypeName(Controllo) = "Line" Then
  232. 'the line control doesn't have Left, Top.... properties, so you must manage it differently
  233. 'you can add here other particular controls - the ones that don't have standard properties
  234.                 .LeftValue = Controllo.X1 'save the original size
  235.                 .TopValue = Controllo.Y1
  236.                 .WidthValue = Controllo.X2
  237.                 .HeightValue = Controllo.Y2
  238.             Else
  239.                 If Controllo.Left < 0 And TypeName(Controllo.Container) = "SSTab" Then
  240.                     .LeftValue = Controllo.Left + 75000
  241. 'add 75000 to record the correct position of controls not located in the current tab
  242.                 Else
  243.                     .LeftValue = Controllo.Left 'save the original size
  244.                 End If
  245.                 .TopValue = Controllo.Top
  246.                 .WidthValue = Controllo.Width
  247.                 .HeightValue = Controllo.Height
  248.                 .FontSizeValue = Controllo.Font.Size
  249.             End If
  250.         End With
  251. Skip:
  252.     Next I
  253.     On Error GoTo 0
  254. TwoExit:
  255. End Sub
  256. Private Sub UpdateControls()
  257. Dim I                As Integer
  258. Dim FFactor          As Single
  259. Dim WFactor          As Single
  260. Dim HFactor          As Single
  261. Static ChangingRatio As Boolean
  262.     On Error Resume Next
  263. 'if not running exit
  264.     If Not Ambient.UserMode Then
  265.         GoTo ThreeExit
  266.     End If
  267. 'prevent recursive calls if KeepAspectRatio is True
  268.     If ChangingRatio Then
  269.         GoTo ThreeExit
  270.     End If
  271.     If KeepAspectRatio And AspectRatioValue > 0 And ParentForm.WindowState = 0 Then
  272. 'if the form is not icon or maximized
  273.         ChangingRatio = True
  274.         ParentForm.Height = AspectRatioValue * ParentForm.Width
  275. 'change the form height to keep aspect ratio
  276.         ChangingRatio = False
  277.     End If
  278.     WFactor = ParentForm.ScaleWidth / ParentWidth
  279. 'calculates the increasing or decreasing factor to use
  280.     HFactor = ParentForm.ScaleHeight / ParentHeight
  281. 'set the font increasing or decreasing factor to the minimum width-height factor
  282.     If WFactor < HFactor Then
  283.         FFactor = WFactor
  284.     Else
  285.         FFactor = HFactor
  286.     End If
  287.     For I = 1 To CtrlTot 'loop through the controls included in the ControlsOnForm array
  288.         With ControlsOnForm(I)
  289.             If TypeName(ParentForm.Controls(.IndexValue)) = "Line" Then
  290. 'if it's a line manage it differently
  291. 'if you added other controls in the StoreOriginalSettings routine
  292. 'add the same controls here
  293.                 ParentForm.Controls(.IndexValue).X1 = .LeftValue * WFactor
  294.                 ParentForm.Controls(.IndexValue).Y1 = .TopValue * HFactor
  295.                 ParentForm.Controls(.IndexValue).X2 = .WidthValue * WFactor
  296.                 ParentForm.Controls(.IndexValue).Y2 = .HeightValue * HFactor
  297.             Else
  298. 'resize the fonts if you enabled Font resizing
  299.                 If FontResizable Then
  300.                     ParentForm.Controls(.IndexValue).Font.Size = .FontSizeValue * FFactor
  301.                 End If
  302.                 If ParentForm.Controls(.IndexValue).Left < 0 And TypeName(ParentForm.Controls(.IndexValue).Container) = "SSTab" Then
  303.                     ParentForm.Controls(.IndexValue).Left = .LeftValue * WFactor - 75000
  304. 'subtract 75000 to keep controls hidden (the ones not located in the current tab)
  305.                 Else
  306.                     ParentForm.Controls(.IndexValue).Left = .LeftValue * WFactor
  307. 'resize the control multiplying the original size for the calculated factor
  308.                 End If
  309.                 ParentForm.Controls(.IndexValue).Top = .TopValue * HFactor
  310.                 ParentForm.Controls(.IndexValue).Width = .WidthValue * WFactor
  311.                 ParentForm.Controls(.IndexValue).Height = .HeightValue * HFactor
  312.             End If
  313.         End With
  314.     Next I
  315.     On Error GoTo 0
  316. ThreeExit:
  317. End Sub
  318. Private Sub UserControl_InitProperties()
  319.     On Error GoTo ErrorTrap
  320. 'Set Default properties values
  321.     FontResizable = True 'Resizing font enabled
  322.     KeepAspectRatio = False 'Keeping aspect ration disabled
  323.     HMin = 3000 'Set the minimum form Height allowed
  324.     WMin = 4800 'Set the minimum form Width allowed
  325.     AspectRatioValue = 0
  326. 'You can set it manually or let the program to do it by enabling KeepAspectRatio property
  327.     Enabled = True  'Autoresize Control enabled
  328.     UserControl.Extender.Tag = "NO" 'Don't include this control among the ones to resize
  329.     UserControl.Extender.Name = "Resize"
  330. 'Name to assign to Autoresize control when you put it on a form
  331. Exit Sub
  332. ErrorTrap:
  333.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  334.        Err.Description & vbNewLine & _
  335.        vbNewLine & _
  336.        "Debug Information:" & vbNewLine & _
  337.        "MidiDateBase.AutoResize.UserControl_InitProperties" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  338. End Sub
  339. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  340.     On Error GoTo ErrorTrap
  341.     With PropBag
  342.         FontResizable = .ReadProperty("FontResizable", True)
  343.         KeepAspectRatio = .ReadProperty("KeepAspectRatio", False)
  344.         AspectRatioValue = .ReadProperty("AspectRatioValue", 0)
  345.         Enabled = .ReadProperty("Enabled", True)
  346.         HMin = .ReadProperty("HMin", 3000)
  347.         WMin = .ReadProperty("WMin", 4800)
  348. 'If not running exit
  349.     End With 'PropBag
  350.     If Ambient.UserMode Then
  351.         Set ParentForm = UserControl.Parent
  352. 'ParentForm is the form containing the autoresize control
  353.     End If
  354. Exit Sub
  355. ErrorTrap:
  356.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  357.        Err.Description & vbNewLine & _
  358.        vbNewLine & _
  359.        "Debug Information:" & vbNewLine & _
  360.        "MidiDateBase.AutoResize.UserControl_ReadProperties" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  361. End Sub
  362. Private Sub UserControl_Resize()
  363.     On Error GoTo ErrorTrap
  364.     UserControl.Width = 400 'Width of autoresize control
  365.     UserControl.Height = 400 'Height of autoresize control
  366. Exit Sub
  367. ErrorTrap:
  368.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  369.        Err.Description & vbNewLine & _
  370.        vbNewLine & _
  371.        "Debug Information:" & vbNewLine & _
  372.        "MidiDateBase.AutoResize.UserControl_Resize" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  373. End Sub
  374. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  375.     On Error GoTo ErrorTrap
  376. 'Save the values assigned to properties
  377.     With PropBag
  378.         .WriteProperty "FontResizable", FontResizable, True
  379.         .WriteProperty "KeepAspectRatio", KeepAspectRatio, False
  380.         .WriteProperty "AspectRatioValue", AspectRatioValue
  381.         .WriteProperty "HMin", HMin, 3000
  382.         .WriteProperty "WMin", WMin, 4800
  383.         .WriteProperty "Enabled", Enabled, True
  384.     End With 'PropBag
  385. Exit Sub
  386. ErrorTrap:
  387.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  388.        Err.Description & vbNewLine & _
  389.        vbNewLine & _
  390.        "Debug Information:" & vbNewLine & _
  391.        "MidiDateBase.AutoResize.UserControl_WriteProperties" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  392. End Sub
  393. Public Property Get WMin() As Long
  394.     On Error GoTo ErrorTrap
  395.     WMin = WM
  396. Exit Property
  397. ErrorTrap:
  398.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  399.        Err.Description & vbNewLine & _
  400.        vbNewLine & _
  401.        "Debug Information:" & vbNewLine & _
  402.        "MidiDateBase.AutoResize.WMin" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  403. End Property
  404. Public Property Let WMin(ByVal Value As Long)
  405.     On Error GoTo ErrorTrap
  406.     WM = Value
  407. Exit Property
  408. ErrorTrap:
  409.     MsgBox "Error Number: " & Err.Number & vbNewLine & _
  410.        Err.Description & vbNewLine & _
  411.        vbNewLine & _
  412.        "Debug Information:" & vbNewLine & _
  413.        "MidiDateBase.AutoResize.WMin" & IIf(Erl > 0, "." & Erl, ""), vbCritical, "Error Occurred"
  414. End Property
  415. ':)Code Fixer V3.0.9 (9/15/2005 1:31:17 PM) 20 + 397 = 417 Lines Thanks Ulli for inspiration and lots of code.
  416.  
  417.  
  418.