关于窗体与分辨率

Question

我的程序的主窗体是一个满屏的窗体，可以适应不同的分辨率，这个没有问题，但是我的主窗体上有一个菜单栏、一个工具条、一个状态条，窗体的其他部分（即中间）是一个Picture Box，分辨率变化的时候它总是不行。不知道大家如何解决这个问题？

Answer 1

Dim a(), g(1) As Single
Dim t As Integer, dt As Integer
Private Sub Form_Activate()
If g(0) = 0 Then '原始值只記錄一次
 g(0) = Form1.ScaleWidth: g(1) = Form1.ScaleHeight '一開始表單的大小
 ReDim a(Form1.Controls.Count - 1, 5)
 j = 0
 For Each i In Form1.Controls '記錄每個物件的資料
   a(j, 0) = i.Name
   On Error Resume Next '避免某些物件沒有指定的屬性而錯誤
   a(j, 1) = i.Left:  a(j, 2) = i.Top
   a(j, 3) = i.Width:  a(j, 4) = i.Height
   a(j, 5) = i.FontSize
   On Error GoTo 0 '取消錯誤處理
  j = j + 1
 Next i
t = 0: dt = 100
End If
End SubPrivate Sub Form_Resize()
If Form1.WindowState <> 1 And g(0) > 0 And g(1) > 0 Then
'重算物件的新位置
 For i = 0 To Form1.Controls.Count - 1
  Set b = Controls(a(i, 0))
   On Error Resume Next
   b.Left = a(i, 1) / g(0) * Form1.ScaleWidth
   b.Top = a(i, 2) / g(1) * Form1.ScaleHeight
   b.Width = a(i, 3) / g(0) * Form1.ScaleWidth
   b.Height = a(i, 4) / g(1) * Form1.ScaleHeight
   If Form1.ScaleWidth / g(0) < Form1.ScaleHeight / g(1) Then
    b.FontSize = a(i, 5) / g(0) * Form1.ScaleWidth
    Else
    b.FontSize = a(i, 5) / g(1) * Form1.ScaleHeight
   End If
   On Error GoTo 0
   
  Set b = Nothing
 Next i
End If
End Sub
Private Sub Timer1_Timer()
 t = t + Sgn(dt)
 If t > 15 Then dt = -dt
 If Form1.WindowState = 2 Then Form1.WindowState = 0: Timer1.Interval = 100: GoTo kk
 If t = 16 Then Form1.WindowState = 2 - Form1.WindowState: Timer1.Interval = 1000: GoTo kk
 Form1.Move (Screen.Width - Form1.Width - dt * 3) / 2, (Screen.Height - Form1.Height - dt) / 2
 Form1.Move Form1.Left, Form1.Top, Form1.Width + dt * 3, Form1.Height + dt
kk:
If dt < 0 And t < 1 Then t = 0: Timer1.Enabled = False
End Sub

Answer 2

Option Explicit
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

Answer 3

一个老外写的控件自适应窗体大小变化的完美代码
’类模块：clsAutoPositioner
Option Explicit
Dim m_oAssignments As New CollectionPublic Function AddAssignment(ctl As Object, _
                                ctlRelative As Object, _
                                tPosType As tPOSITION_TYPE)
    Dim x As New clsAutoPositionerItem
    Set x.oCTL = ctl
    Set x.oREL = ctlRelative
    x.tPosType = tPosType
    
    Select Case x.tPosType
        Case tCONTAINER_RELATIVE_POS_RIGHT:
                x.lValue = x.oREL.Width - x.oCTL.Left
        Case tCONTAINER_RELATIVE_POS_BOTTOM:
                x.lValue = x.oREL.Height - x.oCTL.Top
                
        Case tCONTAINER_WIDTH_DELTA_RIGHT:
                x.lValue = x.oREL.Width - (x.oCTL.Left + x.oCTL.Width)
        Case tCONTAINER_HEIGHT_DELTA_BOTTOM:
                x.lValue = x.oREL.Height - (x.oCTL.Top + x.oCTL.Height)
                
        Case tCONTROL_RELATIVE_SAME_POS_VERTICAL:
                x.lValue = x.oCTL.Left - x.oREL.Left
        Case tCONTROL_RELATIVE_SAME_POS_HORIZONTAL:
                x.lValue = x.oCTL.Top - x.oREL.Top
                
    End Select
    m_oAssignments.Add x
End Function
Public Function RefreshPositions()
    Dim i As Long
    Dim x As clsAutoPositionerItem
    Dim erg As Long
    
    For i = 1 To m_oAssignments.Count
        Set x = m_oAssignments.Item(i)
        Select Case x.tPosType
            Case tCONTAINER_RELATIVE_POS_RIGHT:
                erg = x.oREL.Width - x.lValue
                If (erg > 0) Then x.oCTL.Left = erg
            Case tCONTAINER_RELATIVE_POS_BOTTOM:
                erg = x.oREL.Height - x.lValue
                If (erg > 0) Then x.oCTL.Top = erg
                
            Case tCONTAINER_WIDTH_DELTA_RIGHT:
                erg = x.oREL.Width - x.oCTL.Left - x.lValue
                If (erg > 0) Then x.oCTL.Width = erg
            Case tCONTAINER_HEIGHT_DELTA_BOTTOM:
                erg = x.oREL.Height - x.oCTL.Top - x.lValue
                If (erg > 0) Then
                    x.oCTL.Height = erg
                Else
                    erg = erg
                End If
                
            Case tCONTROL_RELATIVE_SAME_POS_VERTICAL:
                erg = x.oREL.Left + x.lValue
                x.oCTL.Left = erg
            Case tCONTROL_RELATIVE_SAME_POS_HORIZONTAL:
                erg = x.oREL.Top + x.lValue
                x.oCTL.Top = erg
        End Select
    Next
End Function’//////////////////////////////////////////////////////////////////////////////////////////////////////////                                
’类模块：clsAutoPositionerItem
Public Enum tPOSITION_TYPE
    tCONTAINER_RELATIVE_POS_RIGHT
    tCONTAINER_RELATIVE_POS_BOTTOM
    tCONTAINER_WIDTH_DELTA_RIGHT
    tCONTAINER_HEIGHT_DELTA_BOTTOM
    tCONTROL_RELATIVE_SAME_POS_VERTICAL
    tCONTROL_RELATIVE_SAME_POS_HORIZONTAL
End Enum
Public oCTL As Object
Public oREL As Object
Public tPosType As tPOSITION_TYPE
Public lValue As tPOSITION_TYPE’//////////////////////////////////////////////////////////////////////////////////////////////////////////  
’窗体代码：Option Explicit
Dim m_oAutoPos As New clsAutoPositioner
Private Sub Form_Load()
’ Always relative to container’s right border
m_oAutoPos.AddAssignment Me.Command1, Me, tCONTAINER_RELATIVE_POS_RIGHT’ Auto resizing horizontally
m_oAutoPos.AddAssignment Me.Command2, Me, tCONTAINER_WIDTH_DELTA_RIGHT’ Auto resizing vertically
m_oAutoPos.AddAssignment Me.Command3, Me, tCONTAINER_HEIGHT_DELTA_BOTTOM’ Always relative to container’s bottom border
m_oAutoPos.AddAssignment Me.Command4, Me, tCONTAINER_RELATIVE_POS_BOTTOM’ Auto resizing horizontally + Auto resizing vertically
m_oAutoPos.AddAssignment Me.Command5, Me, tCONTAINER_WIDTH_DELTA_RIGHT
m_oAutoPos.AddAssignment Me.Command5, Me, tCONTAINER_HEIGHT_DELTA_BOTTOM
End SubPrivate Sub Form_Resize()
m_oAutoPos.RefreshPositions
End Sub

Answer 4

晕，菜单栏工具条状态条的位置都不用动的啊，当然没问题
如果你没什么特殊要求，根本不需要上面那么复杂的代码
简单的定义一下控件的位置为尺寸就行了假定你的picturebox是满窗体显示的，这样写
Private Sub Form_Resize()
Picture1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
End Sub不管分辨率怎么变，用户如何调整窗体大小，picturebox的大小和位置都可以做出相应变化

Answer 5

Private Sub Form_Load()
    Picture1.Align = vbAlignTop
End SubPrivate Sub Form_Resize()
    Picture1.Height = ScaleHeight
End Sub

Answer 6

如果你说的满屏是指最大化，那么这段可行
Private Sub Form_Resize()
    Picture1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
End Sub如果不是最大化而是手工(代码)把窗体满屏，稍微麻烦一点
要监视系统的改变，一但发现分辨率改变，即进行调整
可以API实现，也可以试试VB自带的SysInfo控件