|
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "FormStretch"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
Option Explicit
'
' these variables define the current size of the form
' we're supporting
'
Private m_Initialized As Boolean
Private m_Mode As Integer
Private m_Width As Single
Private m_Height As Single
Private m_Client As Object
Private m_ChildObjects() As Object
Private Sub Class_Initialize()
'
' default to stretching both horz and vert
'
m_Mode = 3
'
' ensure first pass through stretch routine
' initializes Width and Height
'
m_Width = -1
m_Height = -1
'
' flag to tell us if we have a valid client object
'
m_Initialized = False
End Sub
Property Get Mode() As Integer
'
' get current stretch mode flags
'
Mode = m_Mode
End Property
Property Let Mode(NewMode As Integer)
'
' set new stretch mode flags
'
m_Mode = NewMode
End Property
Property Get Client() As Object
'
' get the current client object
'
Client = m_Client
End Property
Property Set Client(NewClient As Object)
'
' set the new client object
'
Set m_Client = NewClient
'
' clear any children from the child object list
'
ReDim m_ChildObjects(0 To 0)
'
' set intialized flag to true, we now have a valid
' client object
'
m_Initialized = True
'
' get current width and height of client object,
' for use next time we're stretched
'
m_Width = m_Client.Width
m_Height = m_Client.Height
End Property
Public Sub AddChildren(ChildObject As Variant)
Dim I As Integer
Dim LowerBound As Integer
Dim UpperBound As Integer
'
' if the item passed in is not an object, abort
'
If ((VarType(ChildObject) And 9) = 0) And Not IsObject(ChildObject) Then
Exit Sub
End If
'
' special case for a single object
'
If (VarType(ChildObject) And 8192) = 0 Then
'
' resize array and put the new child in it
'
ReDim m_ChildObjects(1 To 1)
Set m_ChildObjects(1) = ChildObject
Else
'
' get bounds of child array
'
LowerBound = LBound(ChildObject)
UpperBound = UBound(ChildObject)
'
' resize array of children to keep object
'
ReDim m_ChildObjects(1 To (UpperBound - LowerBound + 1))
'
' loop through array and get our own copies
' of the objects
'
For I = LowerBound To UpperBound
Set m_ChildObjects(I - LowerBound + 1) = ChildObject(I)
Next I
End If
End Sub
Public Sub Stretch()
Dim NewLeft As Single
Dim NewTop As Single
Dim NewWidth As Single
Dim NewHeight As Single
Dim LowerBound As Integer
Dim UpperBound As Integer
Dim I As Integer
Dim S As Single
Dim DeltaX As Single
Dim DeltaY As Single
Dim SaveFont As Object
'
' if we have no valid client object yet, abort
'
If Not m_Initialized Then
Exit Sub
End If
'
' if the current height and width are uninitialized,
' set them and exit
'
If (m_Width = -1) Or (m_Height = -1) Then
m_Width = m_Client.Width
m_Height = m_Client.Height
Exit Sub
End If
'
' get factor to resize horizontally by
'
If m_Client.Width = m_Width Then
DeltaX = 1
Else
DeltaX = m_Client.Width / m_Width
End If
'
' get factor to resize vertically by
'
If (m_Client.Height = m_Height) Then
DeltaY = 1
Else
DeltaY = m_Client.Height / m_Height
End If
'
' set class Height and Width variables to
' current height and width
'
m_Width = m_Client.Width
m_Height = m_Client.Height
'
' get bounds of children list
'
LowerBound = LBound(m_ChildObjects)
UpperBound = UBound(m_ChildObjects)
'
' if there are no children, abort
'
If (LowerBound = 0) And (UpperBound = 0) Then
Exit Sub
End If
'
' loop through all children
'
For I = LowerBound To UpperBound
'
' get current size of child object
'
NewLeft = m_ChildObjects(I).Left
NewTop = m_ChildObjects(I).Top
NewWidth = m_ChildObjects(I).Width
NewHeight = m_ChildObjects(I).Height
'
' if horizontal resizing is turned on, and we
' have a change in the width of the client
'
If (m_Mode And 2) And (DeltaX <> 1) Then
'
' scale the position of the child
'
NewLeft = NewLeft * DeltaX
'
' if the child is not a label, scale the width
'
If Not (TypeOf m_ChildObjects(I) Is Label) Then
NewWidth = NewWidth * DeltaX
Else
'
' if the child is a label, save the current
' font. labels have no TextWidth method, so
' we're forced to use the client's
'
Set SaveFont = m_Client.Font
Set m_Client.Font = m_ChildObjects(I).Font
'
' compute the minimum width using the label's font
'
S = m_Client.TextWidth(m_ChildObjects(I).Caption)
'
' if the new height is greater than the minimum
' height, use it
'
If NewWidth * DeltaX >= S Then
NewWidth = NewWidth * DeltaX
End If
'
' restore the client's font
'
Set m_Client.Font = SaveFont
End If
End If
'
' if vertical resizing is turned on, and we
' have a change in the height of the client
'
If (m_Mode And 1) And (DeltaY <> 1) Then
'
' scale the position of the child
'
NewTop = NewTop * DeltaY
'
' if the child is not a label, scale the height
'
If Not (TypeOf m_ChildObjects(I) Is Label) Then
NewHeight = NewHeight * DeltaY
Else
'
' if the child is a label, save the current
' font. labels have no TextWidth method, so
' we're forced to use the client's
'
Set SaveFont = m_Client.Font
Set m_Client.Font = m_ChildObjects(I).Font
'
' compute the minimum height using the label's font
'
S = m_Client.TextHeight(m_ChildObjects(I).Caption)
'
' if the new width is greater than the minimum
' width, use it
'
If NewHeight * DeltaY >= S Then
NewHeight = NewHeight * DeltaY
End If
'
' restore the client's font
'
Set m_Client.Font = SaveFont
End If
End If
'
' if the size or position has changed, set it
'
If (NewLeft <> m_ChildObjects(I).Left) Or (NewTop <> m_ChildObjects(I).Top) Or (NewWidth <> m_ChildObjects(I).Width) Or (NewHeight <> m_ChildObjects(I).Height) Then
m_ChildObjects(I).Move NewLeft, NewTop, NewWidth, NewHeight
End If
Next I
End Sub
|
