有时窗体变化后，如改变分辨率后控件大小却不能随之改变。手工代码调整实在麻烦，下面的模块实现自动查找窗体上控件并使其改变大小以适应窗体变化。
在Form的Resize事件中调用函数Resize_All就能实现控件自动调整大小，如：
Private Sub Form_Resize()
Dim H, i As Integer
On Error Resume
Next
Resize_ALL Me 'Me是窗体名，Form1,Form2等等都可以
End
Sub
在模块中添加以下代码：
Public Type ctrObj
Name As String
Index As Long
Parrent As
String
Top As Long
Left As Long
Height As Long
Width As
Long
ScaleHeight As Long
ScaleWidth As Long
End
Type
Private FormRecord() As ctrObj
Private ControlRecord() As
ctrObj
Private bRunning As Boolean
Private MaxForm As
Long
Private MaxControl As Long
Private Const WM_NCLBUTTONDOWN =
&;HA1
Private Declare Function SendMessage Lib "USER32" Alias
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As
Long, ByVal lParam As Long) As Long
Private Declare Function
ReleaseCapture Lib "USER32" () As Long
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
Public Sub ResizeForm(pfrmIn As
Form)
Dim FormControl As Control
Dim isVisible As
Boolean
Dim StartX, StartY, MaxX, MaxY As Long
Dim bNew As
Boolean
If Not bRunning Then
bRunning = True
If
FindForm(pfrmIn) < 0 Then
bNew = True
Else
bNew =
False
End If
If pfrmIn.Top < 30000 Then
isVisible =
pfrmIn.Visible
On Error Resume Next
If Not pfrmIn.MDIChild
Then
On Error GoTo 0
' ' pfrmIn.Visible =
False
Else
If bNew Then
StartY =
pfrmIn.Height
StartX = pfrmIn.Width
On Error Resume
Next
For Each FormControl In pfrmIn
If FormControl.Left +
FormControl.Width + 200 > MaxX Then
MaxX = FormControl.Left +
FormControl.Width + 200
End If
If FormControl.Top +
FormControl.Height + 500 > MaxY Then
MaxY = FormControl.Top +
FormControl.Height + 500
End If
If FormControl.X1 +
200 > MaxX Then
MaxX = FormControl.X1 + 200
End
If
If FormControl.Y1 + 500 > MaxY Then
MaxY =
FormControl.Y1 + 500
End If
If FormControl.X2 + 200
> MaxX Then
MaxX = FormControl.X2 + 200
End
If
If FormControl.Y2 + 500 > MaxY Then
MaxY =
FormControl.Y2 + 500
End If
Next
FormControl
On Error GoTo 0
pfrmIn.Height =
MaxY
pfrmIn.Width = MaxX
End If
On Error GoTo
0
End If
For Each FormControl In
pfrmIn
ResizeControl FormControl, pfrmIn
Next
FormControl
On Error Resume Next
If Not
pfrmIn.MDIChild Then
On Error GoTo 0
pfrmIn.Visible =
isVisible
Else
If bNew Then
pfrmIn.Height =
StartY
pfrmIn.Width = StartX
For Each FormControl In
pfrmIn
ResizeControl FormControl, pfrmIn
Next
FormControl
End If
End If
On Error GoTo 0
End
If
bRunning = False
End If
End Sub
Public Sub
SaveFormPosition(pfrmIn As Form)
Dim i As Long
If MaxForm
> 0 Then
For i = 0 To (MaxForm - 1)
If
FormRecord(i).Name = pfrmIn.Name Then
FormRecord(i).Top =
pfrmIn.Top
FormRecord(i).Left =
pfrmIn.Left
FormRecord(i).Height =
pfrmIn.Height
FormRecord(i).Width = pfrmIn.Width
Exit
Sub
End If
Next i
AddForm (pfrmIn)
End If
End
Sub
Public Sub RestoreFormPosition(pfrmIn As Form)
Dim i As
Long
If MaxForm > 0 Then
For i = 0 To (MaxForm - 1)
If
FormRecord(i).Name = pfrmIn.Name Then
If FormRecord(i).Top < 0
Then
pfrmIn.WindowState = 2
ElseIf FormRecord(i).Top <
30000 Then
pfrmIn.WindowState = 0
pfrmIn.Move
FormRecord(i).Left, FormRecord(i).Top, FormRecord(i).Width,
FormRecord(i).Height
Else
pfrmIn.WindowState = 1
End
If
Exit Sub
End If
Next i
End If
End
Sub
Public Sub Resize_ALL(Form_Name As Form)
Dim OBJ As
Object
For Each OBJ In Form_Name
ResizeControl OBJ,
Form_Name
Next OBJ
End Sub
Public Sub DragForm(frm As
Form)
On Local Error Resume Next
Call
ReleaseCapture
Call SendMessage(frm.hwnd, WM_NCLBUTTONDOWN, 2,
0)
End Sub
[1] [2] 下一页 |
