mn3250
جمعه 02 بهمن 1388, 13:32 عصر
خاطرم نیست منبع کجاست. اگر بعدا دیدم اضافه میکنم.
اول تابع:
Define Class stdresizer As custom
Height = 16
Width = 23
Name = "stdresizer"
*-- Called from the resizer's init...saves the original dimension of all for objects...must be modified so it can be called explicitly when delayed instantiation is used
Procedure saveoriginaldimensions
Lparameters tocontrol
Local loPage, loControl, loColumn, lnCol
*** If the object does not have an AddProperty method,
*** we can't add the properties to save the original dimension.
*** So bail out
If Not Pemstatus( tocontrol, 'AddProperty', 5 )
Return
Endif
With tocontrol
*** Go ahead and add the properties to hold the object's original dimensions
If Pemstatus( tocontrol, 'Width', 5 )
If Not Pemstatus( tocontrol, 'nOriginalWidth', 5 )
.AddProperty( 'nOriginalWidth', .Width )
Endif
Endif
If Pemstatus( tocontrol, 'Height', 5 )
If Not Pemstatus( tocontrol, 'nOriginalHeight', 5 )
.AddProperty( 'nOriginalHeight', .Height )
Endif
Endif
If Pemstatus( tocontrol, 'Top', 5 )
If Not Pemstatus( tocontrol, 'nOriginalTop', 5 )
.AddProperty( 'nOriginalTop', .Top )
Endif
Endif
If Pemstatus( tocontrol, 'Left', 5 )
If Not Pemstatus( tocontrol, 'nOriginalLeft', 5 )
.AddProperty( 'nOriginalLeft', .Left )
Endif
Endif
If Pemstatus( tocontrol, 'Fontsize', 5 )
If Not Pemstatus( tocontrol, 'nOriginalFontSize', 5 )
.AddProperty( 'nOriginalFontSize', .FontSize )
Endif
Endif
*** Now see if we have to drill down. Also, take care of special
*** case like grids where we have to save RowHeight, HeaderHeight, etc
*** And combos where we need to save ColumnWidths
Do Case
Case Upper( .BaseClass ) = 'PAGEFRAME'
For Each loPage In .Pages
This.saveoriginaldimensions( loPage )
Endfor
Case Inlist( Upper( .BaseClass ), 'PAGE', 'CONTAINER' )
For Each loControl In .Controls
This.saveoriginaldimensions( loControl )
Endfor
Case Upper( .BaseClass ) = 'GRID'
If Not Pemstatus( tocontrol, 'nOriginalRowHeight', 5 )
.AddProperty( 'nOriginalRowHeight', .RowHeight )
Endif
If Not Pemstatus( tocontrol, 'nOriginalHeaderHeight', 5 )
.AddProperty( 'nOriginalHeaderHeight', .HeaderHeight )
Endif
If Not Pemstatus( tocontrol, 'nOriginalColumnWidths[ 1 ]', 5 )
.AddProperty( 'nOriginalColumnWidths[ 1 ]' )
Endif
If .ColumnCount > 0
Dimension .nOriginalColumnWidths[ .ColumnCount ]
For lnCol = 1 To .ColumnCount
.nOriginalColumnWidths[lnCol] = .Columns[ lnCol ].Width
Endfor
Endif
Case Inlist( Upper( .BaseClass ), 'COMBOBOX', 'LISTBOX' )
If Not Pemstatus( tocontrol, 'nOriginalColumnWidths', 5 )
.AddProperty( 'nOriginalColumnWidths', .ColumnWidths )
Endif
Case Inlist( Upper( .BaseClass ), 'COMMANDGROUP', 'OPTIONGROUP' )
Local lnButton
For lnButton = 1 To .ButtonCount
This.saveoriginaldimensions( .Buttons[ lnButton ] )
Endfor
Otherwise
*** There is no otherwise...I think we got all cases
Endcase
Endwith
Endproc
*-- Called from the adjustControls method, it resizes and repositions each control it is passed and drills down when necessary
Procedure resizecontrols
Lparameters tocontrol, tnWidthRatio, tnHeightRatio
Local Array lnColumnWidths[ 1 ]
Local loPage, loControl, loColumn, lnCol
With tocontrol
If Pemstatus( tocontrol, 'Width', 5 )
If Pemstatus( tocontrol, 'nOriginalWidth', 5 )
.Width = .nOriginalWidth * tnWidthRatio
Endif
Endif
If Pemstatus( tocontrol, 'Height', 5 )
If Pemstatus( tocontrol, 'nOriginalHeight', 5 )
.Height = .nOriginalHeight * tnHeightRatio
Endif
Endif
If Pemstatus( tocontrol, 'Top', 5 )
If Pemstatus( tocontrol, 'nOriginalTop', 5 )
.Top = .nOriginalTop * tnHeightRatio
Endif
Endif
If Pemstatus( tocontrol, 'Left', 5 )
If Pemstatus( tocontrol, 'nOriginalLeft', 5 )
.Left = .nOriginalLeft * tnWidthRatio
Endif
Endif
*** Now resize the font of the control
*** But only if it is not a grid or an edit box. For these controls,
*** we want to see more info, not a bigger font
If Not Inlist( Upper( .BaseClass ), 'GRID', 'EDITBOX', 'LISTBOX' )
If Pemstatus( tocontrol, 'Fontsize', 5 )
If Pemstatus( tocontrol, 'nOriginalFontSize', 5 )
.FontSize = Iif( Int( .nOriginalFontSize * tnWidthRatio ) < 1, 1, ;
INT( .nOriginalFontSize * tnWidthRatio ) )
Endif
Endif
Endif
Do Case
Case Upper( .BaseClass ) = 'PAGEFRAME'
For Each loPage In .Pages
This.resizecontrols( loPage, tnWidthRatio, tnHeightRatio )
Endfor
Case Inlist( Upper( .BaseClass ), 'PAGE', 'CONTAINER' )
For Each loControl In .Controls
This.resizecontrols( loControl, tnWidthRatio, tnHeightRatio )
Endfor
Case Inlist( Upper( .BaseClass ), 'COMBOBOX', 'LISTBOX' )
Local lnCol, lnStart, lnEnd, lnLen, lcColumnWidths
If .ColumnCount < 2
.ColumnWidths = Alltrim( Str( .Width ) )
Else
lcColumnWidths = ''
lnStart = 1
For lnCol = 1 To .ColumnCount - 1
lnEnd = At( ',', .nOriginalColumnWidths, lnCol )
lnLen = lnEnd - lnStart
lcColumnWidths = lcColumnWidths + ;
IIF( Empty( lcColumnWidths ), '', ',' ) + ;
ALLTRIM( Str( Val( Substr( .nOriginalColumnWidths, lnStart, lnLen ) ) * tnWidthRatio ) )
lnStart = lnEnd + 1
Endfor
lnLen = Len( .nOriginalColumnWidths ) - lnStart + 1
lcColumnWidths = lcColumnWidths + ',' + ;
ALLTRIM( Str( Val( Substr( .nOriginalColumnWidths, lnStart, lnLen ) ) * tnWidthRatio ) )
.ColumnWidths = lcColumnWidths
Endif
Case Inlist( Upper( .BaseClass ), 'COMMANDGROUP', 'OPTIONGROUP' )
Local lnButton
For lnButton = 1 To .ButtonCount
This.resizecontrols( .Buttons[ lnButton ], tnWidthRatio, tnHeightRatio )
Endfor
Otherwise
*** There is no otherwise...I think we got all cases
Endcase
Endwith
Endproc
*-- Called from the form's Resize even, it loops through the form's controls collection and passes a reference to each object to the class's ResizeControls method so it can be resized and/or drilled down into
Procedure adjustcontrols
Lparameter tocontrol
Local llLockScreen, loControl, loParent, lnWidthRatio, lnHeightRatio
If Vartype( tocontrol ) # 'O' And Not Isnull( tocontrol )
loParent = This.Parent
Else
loParent = tocontrol
Endif
*** Bail out if the any of the required properties are not found in the
*** parent container
If Not Pemstatus( Thisform, 'nOriginalWidth', 5 )
Return
Endif
If Not Pemstatus( Thisform, 'nOriginalHeight', 5 )
Return
Endif
With Thisform
lnWidthRatio = .Width / .nOriginalWidth
lnHeightRatio = .Height / .nOriginalHeight
*** Save current status of LockScreen
llLockScreen = .LockScreen
.LockScreen = .T.
For Each loControl In loParent.Controls
This.resizecontrols( loControl, lnWidthRatio, lnHeightRatio )
Endfor
.LockScreen = llLockScreen
Endwith
Endproc
Procedure Init
Local loContainer, loControl
loContainer = This.Parent
With loContainer
*** If the parent continer doesn't have the nOriginalHeight and nOriginalWidth properties
*** then add them and save the form dimensions
If Not Pemstatus( loContainer, 'nOriginalHeight', 5 )
.AddProperty( 'nOriginalHeight', .Height )
Endif
If Not Pemstatus( loContainer, 'nOriginalWidth', 5 )
.AddProperty( 'nOriginalWidth', .Width )
Endif
*** Set a minimun Width and Height to avoid errors later if not
*** already set
If .MinWidth = -1
.MinWidth = .Width / 2
Endif
If .MinHeight = -1
.MinHeight = .Height / 2
Endif
*** Now save the relevant visual properties (height, width, columnwidths, etc)
*** of all the controls on the parent container
For Each loControl In .Controls
This.saveoriginaldimensions( loControl )
Endfor
Endwith
Endproc
Enddefine
در init فرم:
This.NewObject( 'Resizer', 'stdResizer')
RETURN DODEFAULT()
بعد در متد resize فرم:
This.Resizer.AdjustControls()
بعد فرمتون رو تغییر سایز بدید .
اول تابع:
Define Class stdresizer As custom
Height = 16
Width = 23
Name = "stdresizer"
*-- Called from the resizer's init...saves the original dimension of all for objects...must be modified so it can be called explicitly when delayed instantiation is used
Procedure saveoriginaldimensions
Lparameters tocontrol
Local loPage, loControl, loColumn, lnCol
*** If the object does not have an AddProperty method,
*** we can't add the properties to save the original dimension.
*** So bail out
If Not Pemstatus( tocontrol, 'AddProperty', 5 )
Return
Endif
With tocontrol
*** Go ahead and add the properties to hold the object's original dimensions
If Pemstatus( tocontrol, 'Width', 5 )
If Not Pemstatus( tocontrol, 'nOriginalWidth', 5 )
.AddProperty( 'nOriginalWidth', .Width )
Endif
Endif
If Pemstatus( tocontrol, 'Height', 5 )
If Not Pemstatus( tocontrol, 'nOriginalHeight', 5 )
.AddProperty( 'nOriginalHeight', .Height )
Endif
Endif
If Pemstatus( tocontrol, 'Top', 5 )
If Not Pemstatus( tocontrol, 'nOriginalTop', 5 )
.AddProperty( 'nOriginalTop', .Top )
Endif
Endif
If Pemstatus( tocontrol, 'Left', 5 )
If Not Pemstatus( tocontrol, 'nOriginalLeft', 5 )
.AddProperty( 'nOriginalLeft', .Left )
Endif
Endif
If Pemstatus( tocontrol, 'Fontsize', 5 )
If Not Pemstatus( tocontrol, 'nOriginalFontSize', 5 )
.AddProperty( 'nOriginalFontSize', .FontSize )
Endif
Endif
*** Now see if we have to drill down. Also, take care of special
*** case like grids where we have to save RowHeight, HeaderHeight, etc
*** And combos where we need to save ColumnWidths
Do Case
Case Upper( .BaseClass ) = 'PAGEFRAME'
For Each loPage In .Pages
This.saveoriginaldimensions( loPage )
Endfor
Case Inlist( Upper( .BaseClass ), 'PAGE', 'CONTAINER' )
For Each loControl In .Controls
This.saveoriginaldimensions( loControl )
Endfor
Case Upper( .BaseClass ) = 'GRID'
If Not Pemstatus( tocontrol, 'nOriginalRowHeight', 5 )
.AddProperty( 'nOriginalRowHeight', .RowHeight )
Endif
If Not Pemstatus( tocontrol, 'nOriginalHeaderHeight', 5 )
.AddProperty( 'nOriginalHeaderHeight', .HeaderHeight )
Endif
If Not Pemstatus( tocontrol, 'nOriginalColumnWidths[ 1 ]', 5 )
.AddProperty( 'nOriginalColumnWidths[ 1 ]' )
Endif
If .ColumnCount > 0
Dimension .nOriginalColumnWidths[ .ColumnCount ]
For lnCol = 1 To .ColumnCount
.nOriginalColumnWidths[lnCol] = .Columns[ lnCol ].Width
Endfor
Endif
Case Inlist( Upper( .BaseClass ), 'COMBOBOX', 'LISTBOX' )
If Not Pemstatus( tocontrol, 'nOriginalColumnWidths', 5 )
.AddProperty( 'nOriginalColumnWidths', .ColumnWidths )
Endif
Case Inlist( Upper( .BaseClass ), 'COMMANDGROUP', 'OPTIONGROUP' )
Local lnButton
For lnButton = 1 To .ButtonCount
This.saveoriginaldimensions( .Buttons[ lnButton ] )
Endfor
Otherwise
*** There is no otherwise...I think we got all cases
Endcase
Endwith
Endproc
*-- Called from the adjustControls method, it resizes and repositions each control it is passed and drills down when necessary
Procedure resizecontrols
Lparameters tocontrol, tnWidthRatio, tnHeightRatio
Local Array lnColumnWidths[ 1 ]
Local loPage, loControl, loColumn, lnCol
With tocontrol
If Pemstatus( tocontrol, 'Width', 5 )
If Pemstatus( tocontrol, 'nOriginalWidth', 5 )
.Width = .nOriginalWidth * tnWidthRatio
Endif
Endif
If Pemstatus( tocontrol, 'Height', 5 )
If Pemstatus( tocontrol, 'nOriginalHeight', 5 )
.Height = .nOriginalHeight * tnHeightRatio
Endif
Endif
If Pemstatus( tocontrol, 'Top', 5 )
If Pemstatus( tocontrol, 'nOriginalTop', 5 )
.Top = .nOriginalTop * tnHeightRatio
Endif
Endif
If Pemstatus( tocontrol, 'Left', 5 )
If Pemstatus( tocontrol, 'nOriginalLeft', 5 )
.Left = .nOriginalLeft * tnWidthRatio
Endif
Endif
*** Now resize the font of the control
*** But only if it is not a grid or an edit box. For these controls,
*** we want to see more info, not a bigger font
If Not Inlist( Upper( .BaseClass ), 'GRID', 'EDITBOX', 'LISTBOX' )
If Pemstatus( tocontrol, 'Fontsize', 5 )
If Pemstatus( tocontrol, 'nOriginalFontSize', 5 )
.FontSize = Iif( Int( .nOriginalFontSize * tnWidthRatio ) < 1, 1, ;
INT( .nOriginalFontSize * tnWidthRatio ) )
Endif
Endif
Endif
Do Case
Case Upper( .BaseClass ) = 'PAGEFRAME'
For Each loPage In .Pages
This.resizecontrols( loPage, tnWidthRatio, tnHeightRatio )
Endfor
Case Inlist( Upper( .BaseClass ), 'PAGE', 'CONTAINER' )
For Each loControl In .Controls
This.resizecontrols( loControl, tnWidthRatio, tnHeightRatio )
Endfor
Case Inlist( Upper( .BaseClass ), 'COMBOBOX', 'LISTBOX' )
Local lnCol, lnStart, lnEnd, lnLen, lcColumnWidths
If .ColumnCount < 2
.ColumnWidths = Alltrim( Str( .Width ) )
Else
lcColumnWidths = ''
lnStart = 1
For lnCol = 1 To .ColumnCount - 1
lnEnd = At( ',', .nOriginalColumnWidths, lnCol )
lnLen = lnEnd - lnStart
lcColumnWidths = lcColumnWidths + ;
IIF( Empty( lcColumnWidths ), '', ',' ) + ;
ALLTRIM( Str( Val( Substr( .nOriginalColumnWidths, lnStart, lnLen ) ) * tnWidthRatio ) )
lnStart = lnEnd + 1
Endfor
lnLen = Len( .nOriginalColumnWidths ) - lnStart + 1
lcColumnWidths = lcColumnWidths + ',' + ;
ALLTRIM( Str( Val( Substr( .nOriginalColumnWidths, lnStart, lnLen ) ) * tnWidthRatio ) )
.ColumnWidths = lcColumnWidths
Endif
Case Inlist( Upper( .BaseClass ), 'COMMANDGROUP', 'OPTIONGROUP' )
Local lnButton
For lnButton = 1 To .ButtonCount
This.resizecontrols( .Buttons[ lnButton ], tnWidthRatio, tnHeightRatio )
Endfor
Otherwise
*** There is no otherwise...I think we got all cases
Endcase
Endwith
Endproc
*-- Called from the form's Resize even, it loops through the form's controls collection and passes a reference to each object to the class's ResizeControls method so it can be resized and/or drilled down into
Procedure adjustcontrols
Lparameter tocontrol
Local llLockScreen, loControl, loParent, lnWidthRatio, lnHeightRatio
If Vartype( tocontrol ) # 'O' And Not Isnull( tocontrol )
loParent = This.Parent
Else
loParent = tocontrol
Endif
*** Bail out if the any of the required properties are not found in the
*** parent container
If Not Pemstatus( Thisform, 'nOriginalWidth', 5 )
Return
Endif
If Not Pemstatus( Thisform, 'nOriginalHeight', 5 )
Return
Endif
With Thisform
lnWidthRatio = .Width / .nOriginalWidth
lnHeightRatio = .Height / .nOriginalHeight
*** Save current status of LockScreen
llLockScreen = .LockScreen
.LockScreen = .T.
For Each loControl In loParent.Controls
This.resizecontrols( loControl, lnWidthRatio, lnHeightRatio )
Endfor
.LockScreen = llLockScreen
Endwith
Endproc
Procedure Init
Local loContainer, loControl
loContainer = This.Parent
With loContainer
*** If the parent continer doesn't have the nOriginalHeight and nOriginalWidth properties
*** then add them and save the form dimensions
If Not Pemstatus( loContainer, 'nOriginalHeight', 5 )
.AddProperty( 'nOriginalHeight', .Height )
Endif
If Not Pemstatus( loContainer, 'nOriginalWidth', 5 )
.AddProperty( 'nOriginalWidth', .Width )
Endif
*** Set a minimun Width and Height to avoid errors later if not
*** already set
If .MinWidth = -1
.MinWidth = .Width / 2
Endif
If .MinHeight = -1
.MinHeight = .Height / 2
Endif
*** Now save the relevant visual properties (height, width, columnwidths, etc)
*** of all the controls on the parent container
For Each loControl In .Controls
This.saveoriginaldimensions( loControl )
Endfor
Endwith
Endproc
Enddefine
در init فرم:
This.NewObject( 'Resizer', 'stdResizer')
RETURN DODEFAULT()
بعد در متد resize فرم:
This.Resizer.AdjustControls()
بعد فرمتون رو تغییر سایز بدید .