Anchor.ctl

VERSION 5.00
Begin VB.UserControl Anchor 
   CanGetFocus     =   0   'False
   ClientHeight    =   960
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2145
   InvisibleAtRuntime=   -1  'True
   PropertyPages   =   "Anchor.ctx":0000
   ScaleHeight     =   960
   ScaleWidth      =   2145
   ToolboxBitmap   =   "Anchor.ctx":000D
   Begin VB.Image Image1 
      BorderStyle     =   1  'Fixed Single
      Height          =   480
      Left            =   0
      Picture         =   "Anchor.ctx":031F
      Stretch         =   -1  'True
      Top             =   0
      Width           =   480
   End
End
Attribute VB_Name = "Anchor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit

Private Const DEF_SIZE = 0

Private Type udtAnchors
    Control As VB.Control
    Key As String
    Height As Single
    Left As Single
    Top As Single
    Width As Single
    AnchorBottom As Boolean
    AnchorLeft As Boolean
    AnchorRight As Boolean
    AnchorTop As Boolean
End Type

Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpAppName As String, ByVal sKeyName As String, ByVal sString As String, ByVal sFileName As String) As Integer
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpAppName As String, ByVal sKeyName As String, ByVal sDefault As String, ByVal sResult As String, ByVal nSize As Integer, ByVal sFileName As String) As Integer
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long

Private WithEvents mForm As VB.Form
Attribute mForm.VB_VarHelpID = -1

Private mAnchors() As udtAnchors
Private mAnchorCount As Long

Private mOriginalHeight As Single
Private mOriginalWidth As Single
Private mCentreForm As Boolean

Private mMinimumHeight As Single
Private mMaximumHeight As Single
Private mMinimumWidth As Single
Private mMaximumWidth As Single

Public Event BeforeResize()
Public Event AfterResize()
Public Event MoveControl(Control As Object, Left As Single, Top As Single, Width As Single, Height As Single)

Public Function AddAnchor(VBControl As Object, Optional Top As Boolean, Optional Bottom As Boolean, Optional Left As Boolean, Optional Right As Boolean, Optional Key As String) As Long
    If mAnchorCount = 0 Then
        pInitialise
        ParentForm
    End If
    
    mAnchorCount = mAnchorCount + 1
    
    If mAnchorCount > UBound(mAnchors) Then
        ReDim Preserve mAnchors(1 To mAnchorCount + 10)
    End If
    
    If Len(Key) = 0 Then
        Key = GetAnchorKey(VBControl)
    End If
    
    With mAnchors(mAnchorCount)
        Set .Control = VBControl
        
        .Key = Key
        .Height = VBControl.Height
        .Left = VBControl.Left
        .Top = VBControl.Top
        .Width = VBControl.Width
        
        .AnchorBottom = Bottom
        .AnchorLeft = Left
        .AnchorRight = Right
        .AnchorTop = Top
    End With
    
    AddAnchor = mAnchorCount
End Function

Public Property Let AnchorHeight(Anchor As Variant, NewValue As Single)
    Dim ctl As Control
    Dim lCount As Long
    Dim sKey As String
    
    If VarType(Anchor) = vbString Then
        sKey = Anchor
    Else
        Set ctl = Anchor
        sKey = GetAnchorKey(ctl)
    End If
    
    For lCount = LBound(mAnchors) To UBound(mAnchors)
        If mAnchors(lCount).Key = sKey Then
            mAnchors(lCount).Height = NewValue
        End If
    Next lCount
End Property

Public Property Let AnchorLeft(Anchor As Variant, NewValue As Single)
    Dim ctl As Control
    Dim lCount As Long
    Dim sKey As String
    
    If VarType(Anchor) = vbString Then
        sKey = Anchor
    Else
        Set ctl = Anchor
        sKey = GetAnchorKey(ctl)
    End If
    
    For lCount = LBound(mAnchors) To UBound(mAnchors)
        If mAnchors(lCount).Key = sKey Then
            mAnchors(lCount).Left = NewValue
        End If
    Next lCount
End Property

Public Property Let AnchorTop(Anchor As Variant, NewValue As Single)
    Dim ctl As Control
    Dim lCount As Long
    Dim sKey As String
    
    If VarType(Anchor) = vbString Then
        sKey = Anchor
    Else
        Set ctl = Anchor
        sKey = GetAnchorKey(ctl)
    End If
    
    For lCount = LBound(mAnchors) To UBound(mAnchors)
        If mAnchors(lCount).Key = sKey Then
            mAnchors(lCount).Top = NewValue
        End If
    Next lCount
End Property

Public Property Let AnchorWidth(Anchor As Variant, NewValue As Single)
    Dim ctl As Control
    Dim lCount As Long
    Dim sKey As String
    
    If VarType(Anchor) = vbString Then
        sKey = Anchor
    Else
        Set ctl = Anchor
        sKey = GetAnchorKey(ctl)
    End If
    
    For lCount = LBound(mAnchors) To UBound(mAnchors)
        If mAnchors(lCount).Key = sKey Then
            mAnchors(lCount).Width = NewValue
        End If
    Next lCount
End Property

Public Sub CentreForm()
    On Local Error GoTo CentreFormError
    
    With mForm
        If .WindowState = vbNormal Then
            .Left = (Screen.Width - .Width) / 2
            .Top = (Screen.Height - .Height) / 2
        End If
    End With
    Exit Sub

CentreFormError:
    Exit Sub
End Sub

Public Sub Clear()
    Set mForm = Nothing
    pInitialise
End Sub

Private Function GetAnchorKey(Anchor As Object) As String
    If IsControlArray(Anchor) Then
        GetAnchorKey = Anchor.Name & "_" & Anchor.Index
    Else
        GetAnchorKey = Anchor.Name
    End If
End Function

Private Function GetIniValue(sSection As String, sSetting As String, vDefault As Variant, sFile As String) As Variant
    Dim sBuffer As String
    Dim nLength As Integer
    
    sBuffer = Space$(100)
    nLength = GetPrivateProfileString(sSection, sSetting, vDefault, sBuffer, Len(sBuffer), sFile)
    GetIniValue = Left$(sBuffer, nLength)
End Function

Public Function GetWindowSettings(sFile As String, Optional sSection As String) As Boolean
    Dim dValue As Single
    Dim nValue As Integer
    
    On Local Error GoTo GetWindowSettingsError
    
    If mForm Is Nothing Then
        ParentForm
    End If
    
    If Len(sSection) = 0 Then
        sSection = mForm.Name
    End If
    
    nValue = GetIniValue(sSection, "WindowState", 0, sFile)
    
    Select Case nValue
        Case vbMinimized
        
        Case vbMaximized
            mCentreForm = True
            mForm.WindowState = vbMaximized
        
        Case Else
            mForm.WindowState = vbNormal
            
            dValue = GetIniValue(sSection, "WindowHeight", 0, sFile)
            If dValue > 0 Then
                mForm.Height = dValue
            End If
            
            dValue = GetIniValue(sSection, "WindowWidth", 0, sFile)
            If dValue > 0 Then
                mForm.Width = dValue
            End If
    
    End Select
    
    GetWindowSettings = True
    
GetWindowSettingsError:
    Exit Function
End Function

Private Function IsControlArray(VBControl As Object) As Boolean
    Dim nIndex As Integer
    
    On Local Error GoTo IsControlArrayError
    
    nIndex = VBControl.Index
    IsControlArray = True
    Exit Function
    
IsControlArrayError:
    Exit Function
End Function

Public Property Get MaximumHeight() As Single
    MaximumHeight = mMaximumHeight
End Property

Public Property Let MaximumHeight(ByVal vNewValue As Single)
    mMaximumHeight = vNewValue
    
    PropertyChanged "MaximumHeight"
End Property

Public Property Get MaximumWidth() As Single
    MaximumWidth = mMaximumWidth
End Property

Public Property Let MaximumWidth(ByVal vNewValue As Single)
    mMaximumWidth = vNewValue
    
    PropertyChanged "MaximumWidth"
End Property

Private Sub mForm_Resize()
    ResizeForm
    
    If (mForm.WindowState = vbNormal) And mCentreForm Then
        mCentreForm = False
        CentreForm
    End If
End Sub

Public Property Get MinimumHeight() As Single
    MinimumHeight = mMinimumHeight
End Property

Public Property Let MinimumHeight(ByVal vNewValue As Single)
    mMinimumHeight = vNewValue
    
    PropertyChanged "MinimumHeight"
End Property

Public Property Get MinimumWidth() As Single
    MinimumWidth = mMinimumWidth
End Property

Public Property Let MinimumWidth(ByVal vNewValue As Single)
    mMinimumWidth = vNewValue
    
    PropertyChanged "MinimumWidth"
End Property

Private Function ParentForm() As VB.Form
    If mForm Is Nothing Then
        If Ambient.UserMode Then
            Set mForm = UserControl.Parent
            mOriginalHeight = mForm.Height
            mOriginalWidth = mForm.Width
        End If
    End If
    
    Set ParentForm = mForm
End Function

Private Sub pInitialise()
    ReDim mAnchors(1 To 100)
    
    mAnchorCount = 0
End Sub

Private Sub PutIniValue(sSection As String, sSetting As String, vValue As Variant, sFile As String)
    Dim nLength As Integer

    nLength = WritePrivateProfileString(sSection, sSetting, vValue, sFile)
End Sub

Public Sub RemoveAnchor(Anchor As Variant)
    Dim ctl As Control
    Dim lCount As Long
    Dim sKey As String
    
    If VarType(Anchor) = vbString Then
        sKey = Anchor
    Else
        Set ctl = Anchor
        sKey = GetAnchorKey(ctl)
    End If
    
    For lCount = LBound(mAnchors) To UBound(mAnchors)
        If mAnchors(lCount).Key = sKey Then
            Set mAnchors(lCount).Control = Nothing
            mAnchors(lCount).Key = vbNullString
            Exit For
        End If
    Next lCount
End Sub

Private Sub ResizeForm()
    Dim oControl As Control
    Dim dValue As Single
    Dim dLeft As Single
    Dim dTop As Single
    Dim dWidth As Single
    Dim dHeight As Single
    Dim lCount As Long
    
    On Local Error GoTo ResizeFormError
    
    If mForm.WindowState <> vbMinimized Then
        If UBound(mAnchors) > mAnchorCount Then
            ReDim Preserve mAnchors(1 To mAnchorCount)
        End If
        
        RaiseEvent BeforeResize
        
        LockWindowUpdate mForm.HWND
        
        With mForm
            If (.Height > mMaximumHeight) And (mMaximumHeight > 0) Then
                .Height = mMaximumHeight
            ElseIf .Height < mMinimumHeight Then
                .Height = mMinimumHeight
            End If
            
            If (.Width > mMaximumWidth) And (mMaximumWidth > 0) Then
                .Width = mMaximumWidth
            ElseIf .Width < mMinimumWidth Then
                .Width = mMinimumWidth
            End If
        End With
        
        For lCount = LBound(mAnchors) To UBound(mAnchors)
            With mAnchors(lCount)
                Set oControl = .Control
                
                If Not oControl Is Nothing Then
                    dLeft = oControl.Left
                    dTop = oControl.Top
                    dHeight = oControl.Height
                    dWidth = oControl.Width
                
                    If .AnchorBottom Then
                        If .AnchorTop Then
                            dValue = .Height + (mForm.Height - mOriginalHeight)
                            If dValue > 0 Then
                                dHeight = dValue
                            End If
                        Else
                            dValue = mOriginalHeight - .Top
                            dTop = mForm.Height - dValue
                        End If
                    End If
                    
                    If .AnchorRight Then
                        If .AnchorLeft Then
                            dValue = .Width + (mForm.Width - mOriginalWidth)
                            If dValue > 0 Then
                                dWidth = dValue
                            End If
                        Else
                            dValue = mOriginalWidth - .Left
                            dLeft = mForm.Width - dValue
                        End If
                    End If
                    
                    RaiseEvent MoveControl(oControl, dLeft, dTop, dWidth, dHeight)
                    
                    If TypeOf oControl Is ComboBox Then
                        oControl.Move dLeft, dTop, dWidth
                    Else
                        oControl.Move dLeft, dTop, dWidth, dHeight
                    End If
                End If
            End With
        Next lCount
        
        LockWindowUpdate 0
        
        RaiseEvent AfterResize
    End If
    
    Exit Sub

ResizeFormError:
    Resume Next
End Sub

Public Sub RestoreDefault()
    If Ambient.UserMode Then
        If Not mForm Is Nothing Then
            On Local Error GoTo RestoreDefaultError
            
            mForm.WindowState = vbNormal
            mForm.Height = mOriginalHeight
            mForm.Width = mOriginalWidth
        End If
    End If
    
RestoreDefaultError:
    
End Sub

Public Sub SaveWindowSettings(sFile As String, Optional sSection As String)
    If Len(sSection) = 0 Then
        sSection = mForm.Name
    End If
    
    PutIniValue sSection, "WindowState", mForm.WindowState, sFile
    
    If mForm.WindowState = vbNormal Then
        PutIniValue sSection, "WindowHeight", mForm.Height, sFile
        PutIniValue sSection, "WindowWidth", mForm.Width, sFile
    End If
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    pInitialise
    
    mMinimumHeight = PropBag.ReadProperty("MinimumHeight", DEF_SIZE)
    mMaximumHeight = PropBag.ReadProperty("MaximumHeight", DEF_SIZE)
    mMinimumWidth = PropBag.ReadProperty("MinimumWidth", DEF_SIZE)
    mMaximumWidth = PropBag.ReadProperty("MaximumWidth", DEF_SIZE)
End Sub

Private Sub UserControl_Resize()
    UserControl.Height = Image1.Height
    UserControl.Width = Image1.Width
End Sub

Private Sub UserControl_Terminate()
    If Not mForm Is Nothing Then
        Set mForm = Nothing
    End If
    
    Erase mAnchors
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("MinimumHeight", mMinimumHeight, DEF_SIZE)
    Call PropBag.WriteProperty("MaximumHeight", mMaximumHeight, DEF_SIZE)
    Call PropBag.WriteProperty("MinimumWidth", mMinimumWidth, DEF_SIZE)
    Call PropBag.WriteProperty("MaximumWidth", mMaximumWidth, DEF_SIZE)
End Sub