自适应窗体
请教各位，我的VB程序是在1024*768下做的，但是到了800*600下就太大了，现在就想在800*600下运行怎么办啊？怎么能改成在800*600下也能正常显示是啊？请你们说的详细点。：）谢谢！ 我试过一些方法都不行，我希望全部控件都能缩放那种效果。
[解决办法]
我是抄的网上的代码，觉得还算可以：
代码如下：
1 创建一个模块xxx：
2 把以下代码复制到模块xxx中
Option Explicit
Function ActualPos(plLeft As Long) As Long
If plLeft < 0 Then
ActualPos = plLeft + 75000
Else
ActualPos = plLeft
End If
End Function
Function FindForm(pfrmIn As Form) As Long
Dim i As Long
FindForm = -1
If MaxForm > 0 Then
For i = 0 To (MaxForm - 1)
If FormRecord(i).Name = pfrmIn.Name Then
FindForm = i
Exit Function
End If
Next i
End If
End Function
Function AddForm(pfrmIn As Form) As Long
Dim FormControl As Control
Dim i As Long
ReDim Preserve FormRecord(MaxForm + 1)
FormRecord(MaxForm).Name = pfrmIn.Name
FormRecord(MaxForm).Top = pfrmIn.Top
FormRecord(MaxForm).Left = pfrmIn.Left
FormRecord(MaxForm).Height = pfrmIn.Height
FormRecord(MaxForm).Width = pfrmIn.Width
FormRecord(MaxForm).ScaleHeight = pfrmIn.ScaleHeight
FormRecord(MaxForm).ScaleWidth = pfrmIn.ScaleWidth
AddForm = MaxForm
MaxForm = MaxForm + 1
For Each FormControl In pfrmIn
i = FindControl(FormControl, pfrmIn.Name)
If i < 0 Then
i = AddControl(FormControl, pfrmIn.Name)
End If
Next FormControl
End Function
Function FindControl(inControl As Control, inName As String) As Long
Dim i As Long
FindControl = -1
For i = 0 To (MaxControl - 1)
If ControlRecord(i).Parrent = inName Then
If ControlRecord(i).Name = inControl.Name Then
On Error Resume Next
If ControlRecord(i).Index = inControl.Index Then
FindControl = i
Exit Function
End If
On Error GoTo 0
End If
End If
Next i
End Function
Function AddControl(inControl As Control, inName As String) As Long
ReDim Preserve ControlRecord(MaxControl + 1)
On Error Resume Next
ControlRecord(MaxControl).Name = inControl.Name
ControlRecord(MaxControl).Index = inControl.Index
ControlRecord(MaxControl).Parrent = inName
If TypeOf inControl Is Line Then
ControlRecord(MaxControl).Top = inControl.Y1
ControlRecord(MaxControl).Left = ActualPos(inControl.X1)
ControlRecord(MaxControl).Height = inControl.Y2
ControlRecord(MaxControl).Width = ActualPos(inControl.X2)
Else
ControlRecord(MaxControl).Top = inControl.Top
ControlRecord(MaxControl).Left = ActualPos(inControl.Left)
ControlRecord(MaxControl).Height = inControl.Height
ControlRecord(MaxControl).Width = inControl.Width
End If
inControl.IntegralHeight = False
On Error GoTo 0
AddControl = MaxControl
MaxControl = MaxControl + 1
End Function
Function PerWidth(pfrmIn As Form) As Long
Dim i As Long
i = FindForm(pfrmIn)
If i < 0 Then
i = AddForm(pfrmIn)
End If
PerWidth = (pfrmIn.ScaleWidth * 100) \ FormRecord(i).ScaleWidth
End Function
Function PerHeight(pfrmIn As Form) As Double
Dim i As Long
i = FindForm(pfrmIn)
If i < 0 Then
i = AddForm(pfrmIn)
End If
PerHeight = (pfrmIn.ScaleHeight * 100) \ FormRecord(i).ScaleHeight
End Function
Public Sub ResizeControl(inControl As Control, pfrmIn As Form)
On Error Resume Next
Dim i As Long
Dim widthfactor As Single, heightfactor As Single
Dim minFactor As Single
Dim yRatio, xRatio, lTop, lLeft, lWidth, lHeight As Long
yRatio = PerHeight(pfrmIn)
xRatio = PerWidth(pfrmIn)
i = FindControl(inControl, pfrmIn.Name)
If inControl.Left < 0 Then
lLeft = CLng(((ControlRecord(i).Left * xRatio) \ 100) - 75000)
Else
lLeft = CLng((ControlRecord(i).Left * xRatio) \ 100)
End If
lTop = CLng((ControlRecord(i).Top * yRatio) \ 100)
lWidth = CLng((ControlRecord(i).Width * xRatio) \ 100)
lHeight = CLng((ControlRecord(i).Height * yRatio) \ 100)
If TypeOf inControl Is Line Then
If inControl.X1 < 0 Then
inControl.X1 = CLng(((ControlRecord(i).Left * xRatio) \ 100) - 75000)
Else
inControl.X1 = CLng((ControlRecord(i).Left * xRatio) \ 100)
End If
inControl.Y1 = CLng((ControlRecord(i).Top * yRatio) \ 100)
If inControl.X2 < 0 Then
inControl.X2 = CLng(((ControlRecord(i).Width * xRatio) \ 100) - 75000)
Else
inControl.X2 = CLng((ControlRecord(i).Width * xRatio) \ 100)
End If
inControl.Y2 = CLng((ControlRecord(i).Height * yRatio) \ 100)
Else
inControl.Move lLeft, lTop, lWidth, lHeight
inControl.Move lLeft, lTop, lWidth
inControl.Move lLeft, lTop
End If
End Sub
[解决办法]
晕，这样也太长了吧，
我见过短点的，把窗体控件纳入集合，遍历控件，用数组记录控件坐标top，left，控件大小weidth和height，按缩放比例计算出相控件相对窗体的坐标和大小，遍历集合给控件赋值。
网上有这代码，不是很长。
(1)自定义一个数据类型
在标准模块的声明段写入：
Type cp
wp As Single
hp As Single
tp As Single
lp As Single
End Type
(2)定义一个窗体级数组
在窗体模块的声明段写入：
Dim ap() As cp
(3)定义一个通用过程
Sub ai()
Dim i As Integer
For i=0 To Controls.Count-1
With ap(i)
.wp=Controls(i).Width/Form1.ScaleWidth
.hp=Controls(i).Height/Form1.ScaeHeight
.lp=Controls(i).Left/Form1.DcaleWidth
.tp=COntrols(i)，Top/Form1.ScaleHeight
End With
Next i
End Sub
(4)在窗体的Load事件过程中写入代码：
Private Sub Form_Load()
ReDim ap (0 To Controls.Count-1)
ai
End Sub
(5)在窗体的Resize事件过程中写入代码：
Private Sub Form_Resize()
Dim i As Integer
For i=0 To Controls.Count-1
Controls(i).Move ap(i).1p * Form1.ScaleWidth, _
ap(i).tp * Form1.ScaleHeight,ap(i).WP*Form1.ScaleWidth, _
ap(i).hp * Form1.ScaleHeight
Next i
End Sub
如果有不可见控件，如timer等，请加入判断代码避免操作
