【转】Simple CLS for Resizing CTLs on a FRM

本文转自：http://www.daniweb.com/code/snippet34.html

'!! PLACE THE FOLLOWING ON A FRM
Option Explicit
 
'!! THE CLASS IS USED IN THE FOLLOWING WAY
'!! Add the following CMDs to the FRM: cmdMatchWidth, cmdMatchHeight, cmdStayBottomRight
Private mclsFRMResizer As cFRMResizer
'
 
Private Sub Form_Load()
'===============================================================================
  '!! THE FOLLOW LINES ARE FOR THIS EXAMPLE
  '-- Setup FRM
  With Me
	.BorderStyle = 2: .Width = 4755: .Height = 3600
  End With
 
  '-- Setup CMDs
  With Me.cmdMatchWidth
	.Left = 60: .Top = 60: .Width = 4515: .Height = 495
  End With
  With Me.cmdMatchHeight
	.Left = 60: .Top = 600: .Width = 1455: .Height = 2535
  End With
  With Me.cmdStayBottomRight
	.Left = 3120: .Top = 2640: .Width = 1455: .Height = 495
  End With
 
  '-- Initialize and setup 'CFRMResizer'
  Set mclsFRMResizer = New cFRMResizer
  Call mclsFRMResizer.Setup(Me)
  With mclsFRMResizer
	' ex.: .AddCTL [enuFRMResizeType_X], [enuFRMResizeType_Y}
	.AddCTL Me.cmdMatchWidth, ertGrow
	.AddCTL Me.cmdMatchHeight, , ertGrow
	.AddCTL Me.cmdStayBottomRight, ertMove, ertMove
  End With
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
'===============================================================================
  Set mclsFRMResizer = Nothing
End Sub
 
 
'!! PLACE THE FOLLOWING IN A MODULE
Option Explicit
 
'-- The following is used in 'CFRMResizer'
Public Enum enuFRMResizeTypes
  ertGrow = 1 '-- CTL's height/width should increase
  ertMove	 '-- CTL's top/left should increase
End Enum
 
 
'!! PLACE THE FOLLOWING IN A CLASS MODULE WITH THE NAME 'cFRMResizer'
Option Explicit
 
Private Type typResizeCTL
  ctl				 As Control
 
  '-- Defines the X and Y behavior at resize time
  '   (height/top or width/left increased)
  enuFRMResizeType_X  As enuFRMResizeTypes
  enuFRMResizeType_Y  As enuFRMResizeTypes
 
  '-- Used internally for determining new height/top or width/left
  lngOrigCTL_X		As Long
  lngOrigCTL_Y		As Long
End Type
 
Private matypResizeCTLs()   As typResizeCTL
Private mintUBound		  As Integer
 
Private mlngOrigFRMHeight   As Long
Private mlngOrigFRMWidth	As Long
 
Private WithEvents mfrm	 As Form
'
 
Private Sub Class_Initialize()
'===============================================================================
  ReDim matypResizeCTLs(0)
End Sub
 
Private Sub Class_Terminate()
'===============================================================================
  Erase matypResizeCTLs()
  Set mfrm = Nothing
End Sub
 
Public Sub Setup(frm As Form)
'===============================================================================
  Set mfrm = frm
 
  '-- Store original FRM height and width
  With mfrm
	mlngOrigFRMHeight = .Height
	mlngOrigFRMWidth = .Width
  End With
End Sub
 
Public Sub AddCTL(ctl As Control, Optional enuFRMResizeType_X As enuFRMResizeTypes _
	, Optional enuFRMResizeType_Y As enuFRMResizeTypes)
'===============================================================================
  '-- If there aren't any elements
  If Not (mintUBound = 0 And matypResizeCTLs(0).ctl Is Nothing) Then
	'-- Increase array
	mintUBound = mintUBound + 1
	ReDim Preserve matypResizeCTLs(mintUBound)
  End If
 
  With matypResizeCTLs(mintUBound)
	Set .ctl = ctl
 
	'-- Store "X" resize type and determine which "X" value to store in lngOrigCTL_X
	.enuFRMResizeType_X = enuFRMResizeType_X
	Select Case enuFRMResizeType_X
	  Case ertGrow: .lngOrigCTL_X = ctl.Width
	  Case ertMove: .lngOrigCTL_X = ctl.Left
	End Select
 
	'-- Store "Y" resize type and determine which "Y" value to store in lngOrigCTL_Y
	.enuFRMResizeType_Y = enuFRMResizeType_Y
	Select Case enuFRMResizeType_Y
	  Case ertGrow: .lngOrigCTL_Y = ctl.Height
	  Case ertMove: .lngOrigCTL_Y = ctl.Top
	End Select
  End With
End Sub
 
Private Sub mfrm_Resize()
'===============================================================================
  Dim lngCounter		  As Long
  Dim lngFRMHeight		As Long
  Dim lngFRMWidth		 As Long
  Dim lngNewValue		 As Long
 
  '-- Make sure height and width are not less than the original
  With mfrm
	If .Height < mlngOrigFRMHeight Then .Height = mlngOrigFRMHeight
	If .Width < mlngOrigFRMWidth Then .Width = mlngOrigFRMWidth
 
	lngFRMHeight = .Height
	lngFRMWidth = .Width
  End With
 
  For lngCounter = 0 To mintUBound
	With matypResizeCTLs(lngCounter)
	  '-- If a resize type was saved for this CTL's "X"
	  If .enuFRMResizeType_X > 0 Then
		'-- Get new value from mlngOrigFRMWidth and CTL's lngOrigCTL_X
		lngNewValue = lngFRMWidth - (mlngOrigFRMWidth - .lngOrigCTL_X)
		Select Case .enuFRMResizeType_X
		  Case ertGrow: .ctl.Width = lngNewValue
		  Case ertMove: .ctl.Left = lngNewValue
		End Select
	  End If
 
	  '-- If a resize type was saved for this CTL's "Y"
	  If .enuFRMResizeType_Y > 0 Then
		'-- Get new value from mlngOrigFRMHeight and CTL's .lngOrigCTL_Y
		lngNewValue = lngFRMHeight - (mlngOrigFRMHeight - .lngOrigCTL_Y)
		Select Case .enuFRMResizeType_Y
		  Case ertGrow: .ctl.Height = lngNewValue
		  Case ertMove: .ctl.Top = lngNewValue
		End Select
	  End If
	End With
  Next lngCounter
End Sub

'!! PLACE THE FOLLOWING ON A FRM Option Explicit '!! THE CLASS IS USED IN THE FOLLOWING WAY '!! Add the following CMDs to the FRM: cmdMatchWidth, cmdMatchHeight, cmdStayBottomRight Private mclsFRMResizer As cFRMResizer ' Private Sub Form_Load() '=============================================================================== '!! THE FOLLOW LINES ARE FOR THIS EXAMPLE '-- Setup FRM With Me .BorderStyle = 2: .Width = 4755: .Height = 3600 End With '-- Setup CMDs With Me.cmdMatchWidth .Left = 60: .Top = 60: .Width = 4515: .Height = 495 End With With Me.cmdMatchHeight .Left = 60: .Top = 600: .Width = 1455: .Height = 2535 End With With Me.cmdStayBottomRight .Left = 3120: .Top = 2640: .Width = 1455: .Height = 495 End With '-- Initialize and setup 'CFRMResizer' Set mclsFRMResizer = New cFRMResizer Call mclsFRMResizer.Setup(Me) With mclsFRMResizer ' ex.: .AddCTL [enuFRMResizeType_X], [enuFRMResizeType_Y} .AddCTL Me.cmdMatchWidth, ertGrow .AddCTL Me.cmdMatchHeight, , ertGrow .AddCTL Me.cmdStayBottomRight, ertMove, ertMove End With End Sub Private Sub Form_Unload(Cancel As Integer) '=============================================================================== Set mclsFRMResizer = Nothing End Sub '!! PLACE THE FOLLOWING IN A MODULE Option Explicit '-- The following is used in 'CFRMResizer' Public Enum enuFRMResizeTypes ertGrow = 1 '-- CTL's height/width should increase ertMove '-- CTL's top/left should increase End Enum '!! PLACE THE FOLLOWING IN A CLASS MODULE WITH THE NAME 'cFRMResizer' Option Explicit Private Type typResizeCTL ctl As Control '-- Defines the X and Y behavior at resize time ' (height/top or width/left increased) enuFRMResizeType_X As enuFRMResizeTypes enuFRMResizeType_Y As enuFRMResizeTypes '-- Used internally for determining new height/top or width/left lngOrigCTL_X As Long lngOrigCTL_Y As Long End Type Private matypResizeCTLs() As typResizeCTL Private mintUBound As Integer Private mlngOrigFRMHeight As Long Private mlngOrigFRMWidth As Long Private WithEvents mfrm As Form ' Private Sub Class_Initialize() '=============================================================================== ReDim matypResizeCTLs(0) End Sub Private Sub Class_Terminate() '=============================================================================== Erase matypResizeCTLs() Set mfrm = Nothing End Sub Public Sub Setup(frm As Form) '=============================================================================== Set mfrm = frm '-- Store original FRM height and width With mfrm mlngOrigFRMHeight = .Height mlngOrigFRMWidth = .Width End With End Sub Public Sub AddCTL(ctl As Control, Optional enuFRMResizeType_X As enuFRMResizeTypes _ , Optional enuFRMResizeType_Y As enuFRMResizeTypes) '=============================================================================== '-- If there aren't any elements If Not (mintUBound = 0 And matypResizeCTLs(0).ctl Is Nothing) Then '-- Increase array mintUBound = mintUBound + 1 ReDim Preserve matypResizeCTLs(mintUBound) End If With matypResizeCTLs(mintUBound) Set .ctl = ctl '-- Store "X" resize type and determine which "X" value to store in lngOrigCTL_X .enuFRMResizeType_X = enuFRMResizeType_X Select Case enuFRMResizeType_X Case ertGrow: .lngOrigCTL_X = ctl.Width Case ertMove: .lngOrigCTL_X = ctl.Left End Select '-- Store "Y" resize type and determine which "Y" value to store in lngOrigCTL_Y .enuFRMResizeType_Y = enuFRMResizeType_Y Select Case enuFRMResizeType_Y Case ertGrow: .lngOrigCTL_Y = ctl.Height Case ertMove: .lngOrigCTL_Y = ctl.Top End Select End With End Sub Private Sub mfrm_Resize() '=============================================================================== Dim lngCounter As Long Dim lngFRMHeight As Long Dim lngFRMWidth As Long Dim lngNewValue As Long '-- Make sure height and width are not less than the original With mfrm If .Height < mlngOrigFRMHeight Then .Height = mlngOrigFRMHeight If .Width < mlngOrigFRMWidth Then .Width = mlngOrigFRMWidth lngFRMHeight = .Height lngFRMWidth = .Width End With For lngCounter = 0 To mintUBound With matypResizeCTLs(lngCounter) '-- If a resize type was saved for this CTL's "X" If .enuFRMResizeType_X > 0 Then '-- Get new value from mlngOrigFRMWidth and CTL's lngOrigCTL_X lngNewValue = lngFRMWidth - (mlngOrigFRMWidth - .lngOrigCTL_X) Select Case .enuFRMResizeType_X Case ertGrow: .ctl.Width = lngNewValue Case ertMove: .ctl.Left = lngNewValue End Select End If '-- If a resize type was saved for this CTL's "Y" If .enuFRMResizeType_Y > 0 Then '-- Get new value from mlngOrigFRMHeight and CTL's .lngOrigCTL_Y lngNewValue = lngFRMHeight - (mlngOrigFRMHeight - .lngOrigCTL_Y) Select Case .enuFRMResizeType_Y Case ertGrow: .ctl.Height = lngNewValue Case ertMove: .ctl.Top = lngNewValue End Select End If End With Next lngCounter End Sub