Thay đổi toàn bộ control khi zoom form

Miccpro

Thành viên hoạt động
Tham gia ngày
9 Tháng mười hai 2010
Bài viết
160
Được thích
8
Điểm
370
Tuổi
37
Các anh chị cho em hỏi:
Giả sử em có 1 form có kích thước 1000x700 gồm nhiều control đang sử dụng trên màn hình máy tính có kích thước 1600x900. Em muốn khi chuyển file sang máy tính có kích thước màn hình khác là W x H thì form tự động zoom theo tỷ lệ tương ứng =W/1600x100% (các control trong form cũng Resize theo)
Em đã đọc bài https://www.giaiphapexcel.com/diendan/threads/zoom-userform-controls.52745/ nhưng không muốn để chế độ AllowResize nên không áp dụng được.
Mong các anh chị giúp đỡ, em xin cảm ơn
 

giaiphap

Thành viên gạo cội
Tham gia ngày
12 Tháng ba 2007
Bài viết
4,815
Được thích
4,063
Điểm
860
Các anh chị cho em hỏi:
Giả sử em có 1 form có kích thước 1000x700 gồm nhiều control đang sử dụng trên màn hình máy tính có kích thước 1600x900. Em muốn khi chuyển file sang máy tính có kích thước màn hình khác là W x H thì form tự động zoom theo tỷ lệ tương ứng =W/1600x100% (các control trong form cũng Resize theo)
Em đã đọc bài https://www.giaiphapexcel.com/diendan/threads/zoom-userform-controls.52745/ nhưng không muốn để chế độ AllowResize nên không áp dụng được.
Mong các anh chị giúp đỡ, em xin cảm ơn
Chắc bạn muốn thế này à.
 

File đính kèm

HeSanbi

Thành viên tích cực
Tham gia ngày
24 Tháng hai 2013
Bài viết
1,100
Được thích
942
Điểm
560
File trên của Bác giaiphap đề xuất, cần cải tiến như sau:

----------------
PHP:
Option Explicit
#If VBA7 Then
  Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$) As LongPtr
  Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As Long
  #If Win64 Then
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
  #Else
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As Long
  #End If
  Private Style As LongPtr, hWnd As LongPtr
#Else
  Private Style As Long, hWnd As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
  Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$) As Long
#End If
Private Const GWL_STYLE = (-16)
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_THICKFRAME = &H40000
Private Const WS_SIZEBOX = &H40000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MINIMIZE = &H20000000
Private OldWidth#, OldHeight#
#If VBA7 Then
  Private Property Get Handle() As LongPtr
#Else
  Private Property Get Handle() As Long
#End If
  If Val(Application.Version) < 9 Then
      Handle = FindWindow("ThunderXFrame", Caption)  'XL97
  Else
      Handle = FindWindow("ThunderDFrame", Caption)  'XL2000
  End If
End Property
Private Sub UserForm_Initialize()
  hWnd = Handle
  Style = GetWindowLong(hWnd, GWL_STYLE)
  SetWindowLong hWnd, GWL_STYLE, Style Or WS_SIZEBOX Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
  Label3.ForeColor = vbBlue
  Dim I&
  For I = 1 To 12
      ComboBox1.AddItem "Thang " & I
      ListBox1.AddItem "Thang " & I
  Next I
  OldWidth = Me.Width: OldHeight = Me.Height
End Sub
Private Sub UserForm_Terminate()
   SetWindowLong hWnd, GWL_STYLE, Style
End Sub
Private Sub UserForm_Resize()
  Static AllowResize As Boolean
  Dim iZoom As Long, T1#, T2#
  If AllowResize Then Exit Sub Else AllowResize = 1
  If Me.Width < 200 Then Me.Width = 200
  If Me.Height < 150 Then Me.Height = 150
  T1 = Me.Width / OldWidth * 100: T2 = Me.Height / OldHeight * 100
  iZoom = IIf(T1 > T2, T2, T1)
  Me.Zoom = iZoom
  AllowResize = 0
End Sub
Private Sub cmdCLose_Click()
    Unload Me
End Sub
 

Miccpro

Thành viên hoạt động
Tham gia ngày
9 Tháng mười hai 2010
Bài viết
160
Được thích
8
Điểm
370
Tuổi
37
File trên của Bác giaiphap đề xuất, cần cải tiến như sau:

----------------
PHP:
Option Explicit
#If VBA7 Then
  Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$) As LongPtr
  Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As Long
  #If Win64 Then
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
  #Else
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As Long
  #End If
  Private Style As LongPtr, hWnd As LongPtr
#Else
  Private Style As Long, hWnd As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
  Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$) As Long
#End If
Private Const GWL_STYLE = (-16)
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_THICKFRAME = &H40000
Private Const WS_SIZEBOX = &H40000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MINIMIZE = &H20000000
Private OldWidth#, OldHeight#
#If VBA7 Then
  Private Property Get Handle() As LongPtr
#Else
  Private Property Get Handle() As Long
#End If
  If Val(Application.Version) < 9 Then
      Handle = FindWindow("ThunderXFrame", Caption)  'XL97
  Else
      Handle = FindWindow("ThunderDFrame", Caption)  'XL2000
  End If
End Property
Private Sub UserForm_Initialize()
  hWnd = Handle
  Style = GetWindowLong(hWnd, GWL_STYLE)
  SetWindowLong hWnd, GWL_STYLE, Style Or WS_SIZEBOX Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
  Label3.ForeColor = vbBlue
  Dim I&
  For I = 1 To 12
      ComboBox1.AddItem "Thang " & I
      ListBox1.AddItem "Thang " & I
  Next I
  OldWidth = Me.Width: OldHeight = Me.Height
End Sub
Private Sub UserForm_Terminate()
   SetWindowLong hWnd, GWL_STYLE, Style
End Sub
Private Sub UserForm_Resize()
  Static AllowResize As Boolean
  Dim iZoom As Long, T1#, T2#
  If AllowResize Then Exit Sub Else AllowResize = 1
  If Me.Width < 200 Then Me.Width = 200
  If Me.Height < 150 Then Me.Height = 150
  T1 = Me.Width / OldWidth * 100: T2 = Me.Height / OldHeight * 100
  iZoom = IIf(T1 > T2, T2, T1)
  Me.Zoom = iZoom
  AllowResize = 0
End Sub
Private Sub cmdCLose_Click()
    Unload Me
End Sub
Nhờ bác giúp em thành kiểu Function hoặc cách gì mà mỗi form chỉ 1 hoặc 2 hàm thôi được không ạ. Chứ file em khoảng hơn 10 form mà form nào cũng dài thế này thì toang ạ :p :p :p
 

NguyenthiH

thành viên mù VBA
Tham gia ngày
11 Tháng mười hai 2016
Bài viết
627
Được thích
85
Điểm
220
Mình thấy bạn đã vào topic" có thể tạo Userform vừa khít với các loại màn hình" rồi mà, mình thấy code của Thầy batman1 rất tốt, form mình xài mang qua máy nào đều vừa mà.
 

Miccpro

Thành viên hoạt động
Tham gia ngày
9 Tháng mười hai 2010
Bài viết
160
Được thích
8
Điểm
370
Tuổi
37
Mình thấy bạn đã vào topic" có thể tạo Userform vừa khít với các loại màn hình" rồi mà, mình thấy code của Thầy batman1 rất tốt, form mình xài mang qua máy nào đều vừa mà.
Cảm ơn bác đã nhắc nhở, mục đích topic này khác trước bác à. Cái này là form zoom theo 1 tỷ lệ nào đó chứ không phải full màn hình
 

HeSanbi

Thành viên tích cực
Tham gia ngày
24 Tháng hai 2013
Bài viết
1,100
Được thích
942
Điểm
560
Có 1 đòi 10 đó là bản tính con người khó trách
-------------------
Userform Code:
PHP:
Option Explicit
#If Win64 Then
  Dim hWnd As LongPtr, Style As LongPtr
#Else
  Dim hWnd As Long, Style As Long
#End If
Dim oWidth%, oHeight%
Private Sub UserForm_Initialize()
  FormInitialize Me, hWnd, Style, oWidth, oHeight
End Sub
Private Sub UserForm_Terminate()
  FormTerminate hWnd, Style
End Sub
Private Sub UserForm_Resize()
  FormResize Me, 200, 150, oWidth, oHeight
End Sub
Private Sub cmdCLose_Click()
    Unload Me
End Sub
-----------------------
Module
-----------------------
PHP:
Option Explicit
#If VBA7 Then
  Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$) As LongPtr
  Public Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As Long
  #If Win64 Then
    Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As LongPtr
    Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
  #Else
    Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As Long
    Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As Long
  #End If
#Else
  Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
  Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
  Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$) As Long
#End If
Public Const GWL_STYLE = (-16)
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_THICKFRAME = &H40000
Public Const WS_SIZEBOX = &H40000
Public Const WS_MAXIMIZE = &H1000000
Public Const WS_MINIMIZE = &H20000000

#If VBA7 Then
Public Function FormHandle(Optional ByVal Caption$ = vbNullString) As LongPtr
#Else
Public Function FormHandle(Optional ByVal Caption$ = vbNullString) As Long
#End If
  If Val(Application.Version) < 9 Then
      FormHandle = FindWindow("ThunderXFrame", Caption)  'XL97
  Else
      FormHandle = FindWindow("ThunderDFrame", Caption)  'XL2000
  End If
End Function

#If VBA7 Then
Public Sub FormInitialize(ByVal Form As Object, _
                          ByRef hWnd As LongPtr, _
                          ByRef Style As LongPtr, _
                          ByRef oWidth%, _
                          ByRef oHeight%)
#Else
Public Sub FormInitialize(ByVal Form As Object, _
                          ByRef hWnd As Long, _
                          ByRef Style As Long, _
                          ByRef oWidth%, _
                          ByRef oHeight%)
#End If
  hWnd = FormHandle
  Style = GetWindowLong(hWnd, GWL_STYLE)
  SetWindowLong hWnd, GWL_STYLE, Style Or WS_SIZEBOX Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
  oWidth = Form.Width: oHeight = Form.Height
End Sub
#If VBA7 Then
Public Sub FormTerminate(ByVal hWnd As LongPtr, ByVal Style As LongPtr)
#Else
Public Sub FormTerminate(ByVal hWnd As LongPtr, ByVal Style As LongPtr)
#End If
   SetWindowLong hWnd, GWL_STYLE, Style
End Sub
Public Sub FormResize(ByVal Form As Object, _
             Optional ByVal LWidth% = 200, _
             Optional ByVal LHeight% = 200, _
             Optional ByVal oWidth% = 200, _
             Optional ByVal oHeight% = 200)
  Static AllowResize As Boolean
  Dim iZoom As Long, T1#, T2#
  If AllowResize Then Exit Sub Else AllowResize = 1
  If Form.Width < LWidth Then Form.Width = LWidth
  If Form.Height < LHeight Then Form.Height = LHeight
  T1 = Form.Width / oWidth * 100: T2 = Form.Height / oHeight * 100
  iZoom = IIf(T1 > T2, T2, T1)
  Form.Zoom = iZoom
  AllowResize = 0
End Sub
 
Top Bottom