VBA窗体控件随窗口大小而自动调整

liuruojun

网上找到两段代码
1、以下代码可自由拉伸窗口大小，但窗口控件不会变化
#If VBA7 Then
  Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowW" (ByVal lpClassName As LongPtr, _
    ByVal lpWindowName As LongPtr) As Long
  Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hWnd As Long, _
    ByVal nIndex As Long) As Long
  Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, _
    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#Else
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowW" (ByVal lpClassName As Long, _
    ByVal lpWindowName As Long) As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hWnd As Long, _
    ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, _
    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If

Dim hWnd As Long

  hWnd = FindWindow(StrPtr("ThunderDFrame"), StrPtr(Me.Caption))
  SetWindowLong hWnd, -16, GetWindowLong(hWnd, -16) Or &H40000 Or &H20000 Or &H10000


2、以下代码可以实现控件随窗口大小变化，但窗口不可以自由调整大小

'Option Explicit
'Dim frmW, frmH
'Dim i
'
'Private Sub Form_Load()
'If WindowState <> vbMaximized Then
'frmW = Me.Width
'frmH = Me.Height
'End If
'For i = 0 To Ms1.Cols - 1
'Ms1.ColWidth(i) = Int((Ms1.Width - 360) / Ms1.Cols)
'Next
'End Sub
'
'Private Sub Form_Resize()
'On Error Resume Next
'If frmW = 0 Or frmH = 0 Then Exit Sub
'Dim c As Control, x, y
'x = Me.Width / frmW
'y = Me.Height / frmH
'For Each c In Me.Controls
'With c
'.Left = Int(.Left * x)
'.Top = Int(.Top * y)
'.Width = Int(.Width * x)
'.Height = Int(.Height * y)
'End With
'Next
'For i = 0 To Ms1.Cols - 1
'Ms1.ColWidth(i) = Int(Ms1.ColWidth(i) * x)
'Next
'frmW = Me.Width
'frmH = Me.Height
'End Sub


'Dim p As Object, x, y
'With Application
'.WindowState = xlMaximized
'x = .Width / Me.Width
'y = .Height / Me.Height
'For Each p In Me.Controls
'p.Move p.Left * x, p.Top * y, p.Width * x, p.Height * y
'Next
'Me.Move .Left, .Top, .Width, .Height
'End With


求大神把这两段代码综合写一下新代码，可自由拉伸窗口，窗口控件随窗口大小自动调整大小。

exorca

参考~
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowW" (ByVal lpClassName As LongPtr, _
    ByVal lpWindowName As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hWnd As Long, _
    ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, _
    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowW" (ByVal lpClassName As Long, _
    ByVal lpWindowName As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hWnd As Long, _
    ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, _
    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If

Private Sub UserForm_Initialize()
    Dim hWnd As Long
    'hWnd = FindWindow(StrPtr("ThunderDFrame"), StrPtr(Me.Caption))
    'SetWindowLong hWnd, -16, GetWindowLong(hWnd, -16) Or &H40000 Or &H20000 Or &H10000
    'Debug.Print hWnd

    Application.WindowState = xlNormal

End Sub

Private Sub UserForm_Resize()
    Dim frmW, frmH
    frmW = Me.Width
    frmH = Me.Height

    Dim c As Control
    For Each c In Me.Controls
        c.Left = 0
        c.Width = frmW
    Next

End Sub

大灰狼1976

可以实现，但我的方法很简单，没有使用API。
附件请测试，在窗体空白处拖拉即可。

大灰狼1976

加一句repaint减少拉伸过程中的窗体闪动和残影，至少在我这边是有肉眼可见效果的。

liuruojun

大灰狼1976 发表于 2021-12-24 19:01
可以实现，但我的方法很简单，没有使用API。
附件请测试，在窗体空白处拖拉即可。

谢谢大佬，，非常感谢，已完美解决

liuruojun

exorca 发表于 2021-12-24 18:55
参考~
Option Explicit

已调用，可行，谢谢指点。

02761752696

谢谢   分享   很实用

zn1993

大灰狼1976 发表于 2021-12-24 21:16
加一句repaint减少拉伸过程中的窗体闪动和残影，至少在我这边是有肉眼可见效果的。

66666666666666666666666