如何实现将窗体最大化的时候里面的控件也按一定的比例放大(设计时只是一个小窗体,想以最大化显示)
解决方案 »
- 女程序员求助文件监控问题
- 我的程序有这样一个需求
- 关于VB5实现split功能的问题
- 如何将存储过程中的纪录集调入datagrid中?请大家帮我找找错误!!
- vb6.0 判断星期,获取时间,想用一个时间控件DTPicker1,实现以下功能:
- 我用VB做报表,打开时提示"报表宽度大于纸张宽度"这是什么原因`~在线等,急~~帮个忙~~~
- 请问如何新建一个ACCESS数据库,而不是一个表? 十万火急~~~~
- 我在moudule 执行这个操作(看内容),为什么没有结果 (在线等待到1:30)
- 非常初级的问题
- tray中的圖標響應鼠標單雙擊的API?
- 如何引用Collect 的Key 属性
- 这句SELECT语句该怎么写???
http://www.96116.net/6/autoresize.zip
Option ExplicitPrivate Sub Form_Resize() '确保窗体改变时控件随之改变
Call ResizeForm(Me)
End SubPrivate Sub Form_Load() '在程序装入时必须加入
Call ResizeInit(Me)
End Sub模块Option ExplicitPrivate ObjOldWidth As Long '保存窗体的原始宽度
Private ObjOldHeight As Long '保存窗体的原始高度
Private ObjOldFont As Single '保存窗体的原始字体比'在调用ResizeForm前先调用本函数
Public Sub ResizeInit(FormName As Form) Dim Obj As Control
ObjOldWidth = FormName.ScaleWidth
ObjOldHeight = FormName.ScaleHeight
ObjOldFont = FormName.Font.Size / ObjOldHeightOn Error Resume Next
For Each Obj In FormName
Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "
Next Obj
On Error GoTo 0End Sub'按比例改变表单内各元件的大小,
'在调用ReSizeForm前先调用ReSizeInit函数
Public Sub ResizeForm(FormName As Form) Dim Pos(4) As Double
Dim i As Long, TempPos As Long, StartPos As Long
Dim Obj As Control
Dim ScaleX As Double, ScaleY As Double
ScaleX = FormName.ScaleWidth / ObjOldWidth
'保存窗体宽度缩放比例
ScaleY = FormName.ScaleHeight / ObjOldHeight
'保存窗体高度缩放比例
On Error Resume Next
For Each Obj In FormName
StartPos = 1
For i = 0 To 4
'读取控件的原始位置与大小
TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)
If TempPos > 0 Then
Pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
StartPos = TempPos + 1
Else
Pos(i) = 0
End If
'根据控件的原始位置及窗体改变大
'小的比例对控件重新定位与改变大小
Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY
Obj.Font.Size = ObjOldFont * FormName.ScaleHeight
Next i
Next Obj
On Error GoTo 0End Sub
'事。有的人设置窗体Resizable但却不改变控件的大小;有的人则根据控件的
'绝对位置与窗口大小相加减的办法来重新定位控件与改变大小,这种办法比
'较繁琐,且不可重用;当然也有人则限定窗口干脆不让改变。
'下面给出一个一劳永逸的办法,源程序如下:Private FormOldWidth As Long
'原始宽度
Private FormOldHeight As Long
'原始高度'在调用ResizeForm前先调用本函数
Public Sub ResizeInit(FormName As Form)
Dim Obj As Control
FormOldWidth = FormName.ScaleWidth
FormOldHeight = FormName.ScaleHeight
On Error Resume Next
For Each Obj In FormName
Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "
Next Obj
On Error GoTo 0
End Sub'按比例改变表单内各元件的大小,
'在调用ReSizeForm前先调用ReSizeInit函数
Public Sub ResizeForm(FormName As Form)
Dim Pos(4) As Double
Dim i As Long, TempPos As Long, StartPos As Long
Dim Obj As Control
Dim ScaleX As Double, ScaleY As DoubleScaleX = FormName.ScaleWidth / FormOldWidth
'保存窗体宽度缩放比例
ScaleY = FormName.ScaleHeight / FormOldHeight
'保存窗体高度缩放比例
On Error Resume Next
For Each Obj In FormName
StartPos = 1
For i = 0 To 4
'读取控件的原始位置与大小TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)
If TempPos > 0 Then
Pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
StartPos = TempPos + 1
Else
Pos(i) = 0
End If
'根据控件的原始位置及窗体改变大小
'的比例对控件重新定位与改变大小
Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY
Next i
Next Obj
On Error GoTo 0
End SubPrivate Sub Form_Load()
Call ResizeInit(Me) '在装入时必须加入
End SubPrivate Sub Form_Resize()
Call ResizeForm(Me) '控件随之改变
End Sub方法二 WINDOWS下的窗口一般都可以通过鼠标拖动来扩 大,有些时候我们需要控制窗口的比例不变,以防窗口比例失调时造成界面的不协调。要做 到这一点,可以利用API函数CallWindwosProc,当得到用户调整窗口的消息时,判断X或Y方 向上的比例是否和原来的比例一样,如果不一样,则调整为一样。下面是一个例子。
Private Sub Command1_Click()
UnloadMe
EndSubPrivate Sub Form_Load()
OldWindowProc=SetWindowLong(hwnd,GWL_WNDPROC,AddressOf NewWindowProc)
EndSub模块中: Public OldWindowProc As Long
声明API函数如下:
Declare Function CallWindowProc Lib"user32"Alias"CallWindowProcA"(ByVal lpPrevWndFunc As
Long,ByVal hwnd As Long,ByValmsg As Long,ByVal wParam As Long,lParam As WINDOWPOS)As Long
Declare Function SetWindowLong Lib "user32"Alias"SetWindowLongA" (alhwnd As
Long,ByValnIndex As Long,ByVal dwNewLong As Long)As LongConst GWL_WNDPROC=-4
定义一个窗口位置数据类型
Type WINDOWPOS
hwnd As Long
hWndInsertAfter As Long
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End Type
Const WM_WINDOWPOSCHANGING=&H46
Const WM_WINDOWPOSCHANGED=&H47
处理窗口变化的函数
PublicFunctionNewWindowProc(ByVal hwnd As Long,ByVal msg As Long,ByVal wParam As
Long,lParam As WINDOWPOS)As Long
Static done_before As Boolean
Static aspect As Single
Dim new_aspect As SingleIf msg=WM_WINDOWPOSCHANGING Then
If lParam.cy>0 Then
保存原来的比例
If Notdone_before Then
aspect=lParam.cx/lParam.cy
done_before=True
End Ifnew_aspect=lParam.cx/lParam.cy
If new_aspect>aspect Then
lParam.cy=lParam.cx/aspect
Else
lParam.cx=aspect*lParam.cy
End If
End If
End IfNewWindowProc=CallWindowProc
(OldWindowProc,hwnd,msg,wParam,lParam)End Function
注意:有些控件无法正常缩放的
楼上的通用代码就不错。
也可以视问题的不同用不同代码解决。