resizer.ctl

可以自动调整窗体内控件大小 方便实用

VERSION 5.00
Begin VB.UserControl Resizer 
   ClientHeight    =   4065
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4275
   InvisibleAtRuntime=   -1  'True
   ScaleHeight     =   4065
   ScaleWidth      =   4275
   ToolboxBitmap   =   "Resizer.ctx":0000
   Begin VB.Image Image1 
      Height          =   450
      Left            =   0
      Picture         =   "Resizer.ctx":0182
      Stretch         =   -1  'True
      Top             =   0
      Width           =   480
   End
End
Attribute VB_Name = "Resizer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

' **********************************************************************
'  描  述：自动调整屏幕控件大小的控件
'  Play78.com : 网站导航，源码之家，绝对开源
'  海阔天空收集整理
'  网址：http://www.play78.com/
'  QQ：13355575
'  e-mail:[e-mail]
'  编写日期：2005年08月19日
' **********************************************************************

Option Explicit

' if True, also fonts are resized
Public ResizeFont As Boolean
' if True, form's height/width ratio is preserved
Public KeepRatio As Boolean

Private Type TControlInfo
    ctrl As Control
    Left As Single
    Top As Single
    Width As Single
    Height As Single
    FontSize As Single
    FontName As String
End Type

' this array holds the original position
' and size of all controls on parent form
Dim Controls() As TControlInfo

' a reference to the parent form
Private WithEvents ParentForm As Form
Attribute ParentForm.VB_VarHelpID = -1
' parent form's size at load time
Private ParentWidth As Single
Private ParentHeight As Single
' ratio of original height/width
Private HeightWidthRatio As Single

Private Sub ParentForm_Load()
    ' the ParentWidth variable works as a flag
    ParentWidth = 0
    ' save original ratio
    HeightWidthRatio = ParentForm.Height / ParentForm.Width
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    If Ambient.UserMode = False Then Exit Sub
    ' store a reference to the parent form and
    ' start receiving events
    Set ParentForm = Parent
End Sub

Private Sub UserControl_Resize()
    ' refuse to resize
    Image1.Move 0, 0
    UserControl.Width = Image1.Width
    UserControl.Height = Image1.Height
End Sub

' trap the parent form's Resize event
' this include the very first resize event
' that occurs soon after form's load

Private Sub ParentForm_Resize()
    If ParentWidth = 0 Then
        Rebuild
    Else
        Refresh
    End If
End Sub

' save size and position of all controls on parent form
' you should manually invoke this method each time you add a new control
' to the form (through Load method of a control array)

Sub Rebuild()
    ' rebuild the internal table
    Dim i As Integer, ctrl As Control
    ' this is necessary for controls that don't support
    ' all properties (e.g. Timer controls)
    On Error Resume Next
    
    If Ambient.UserMode = False Then Exit Sub
    
    ' save a reference to the parent form, and its initial size
    Set ParentForm = UserControl.Parent
    ParentWidth = ParentForm.ScaleWidth
    ParentHeight = ParentForm.ScaleHeight
    
    ' read the position of all controls on the parent form
    ReDim Controls(ParentForm.Controls.Count - 1) As TControlInfo
    
    For i = 0 To ParentForm.Controls.Count - 1
        Set ctrl = ParentForm.Controls(i)
        With Controls(i)
            Set .ctrl = ctrl
            .Left = ctrl.Left
            .Top = ctrl.Top
            .Width = ctrl.Width
            .Height = ctrl.Height
            .FontSize = ctrl.Font.Size
            .FontName = ctrl.Font.Name
        End With
    Next
End Sub

' update size and position of controls on parent form

Sub Refresh()
    Dim i As Integer, ctrl As Control
    Dim widthFactor As Single, heightFactor As Single
    Dim minFactor As Single
    
    ' inhibits recursive calls if KeepRatio = True
    Static executing As Boolean
    If executing Then Exit Sub
    
    If Ambient.UserMode = False Then Exit Sub
    
   If KeepRatio Then
      executing = True
      ' we must keep original ratio
      If ParentForm.WindowState = vbNormal Then
         ParentForm.Height = HeightWidthRatio * ParentForm.Width
      End If
      executing = False
   End If
    
    ' this is necessary for controls that don't support
    ' all properties (e.g. Timer controls)
    On Error Resume Next

    widthFactor = ParentForm.ScaleWidth / ParentWidth
    heightFactor = ParentForm.ScaleHeight / ParentHeight
    ' take the lesser of the two
    If widthFactor < heightFactor Then
        minFactor = widthFactor
    Else
        minFactor = heightFactor
    End If
    
   ' this is a regular resize
   For i = 0 To UBound(Controls)

      With Controls(i)
         ' the change of font must occur *before* the resizing
         ' to account for companion scrollbar of listbox
         ' and other similar controls
         If ResizeFont Then
            '.ctrl.Font.Size = .FontSize * minFactor
            If (.FontSize * minFactor) < 8 Then
               .ctrl.Font.Name = "Small Fonts"
               If (.FontSize * minFactor) > 7 Then
                  .ctrl.Font.Size = 7
               Else
                  .ctrl.Font.Size = .FontSize * minFactor
               End If
            ElseIf .ctrl.Font.Name <> .FontName Then
               .ctrl.Font.Name = .FontName
               .ctrl.Font.Size = .FontSize * minFactor
            Else
               .ctrl.Font.Size = .FontSize * minFactor
            End If
         End If
         ' move and resize the controls - we can't use a Move
         ' method because some controls do not support the change
         ' of all the four properties (e.g. Height with comboboxes)
         
          If .ctrl.Left < 0 Then
             .ctrl.Left = ((.ctrl.Left + 75000) * widthFactor) - 75000
          ElseIf .Left < 0 Then
             .ctrl.Left = (.Left + 75000) * widthFactor
          Else
             .ctrl.Left = .Left * widthFactor
          End If
          .ctrl.Top = .Top * heightFactor
         '对控件的大小调整合理化
         Select Case TypeName(.ctrl)
            Case "TextBox"
              .ctrl.Width = .Width * widthFactor
              If .ctrl.MultiLine Then
                 .ctrl.Height = .Height * heightFactor
              End If
            Case "CommandButton", "Label", "CheckBox"
            
            Case Else
              .ctrl.Width = .Width * widthFactor
              .ctrl.Height = .Height * heightFactor
         End Select
      End With
   Next
   
End Sub