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

Liên hệ QC
M

Miccpro

Thành viên thường trực
Tham gia
9/12/10
Bài viết
236
Được thích
10
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
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Miccpro đã viết:
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
Nhấp chuột vào đây để mở rộng...
Chắc bạn muốn thế này à.
 

File đính kèm

  • ZoomFormAndControls.xls
    56 KB · Đọc: 23
Upvote 0
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
 
Upvote 0
HeSanbi đã viết:
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ấp chuột vào đây để mở rộng...
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
 
Upvote 0
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à.
 
Upvote 0
NguyenthiH đã viết:
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à.
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

H
Nhờ hướng dẫn chuyển hàng thành cột và dữ liệu theo nhu cầu bằng VBA
Trả lời
1
Đọc
47
DeTong
D
H
  • Question
Code VBA cho kết quả dòng, cột theo điều kiện từ 2 Sheets
Trả lời
2
Đọc
71
SA_DQ
SA_DQ
NguyenthiH
  • Question
Code lấy dữ liệu cho sheet!TonDau.
Trả lời
2
Đọc
61
NguyenthiH
NguyenthiH
T
Cần giúp sao chép C1 từ B1
Trả lời
3
Đọc
82
tle2003
T
A
Tìm số nhỏ nhất, số lớn nhất theo ngày
Trả lời
6
Đọc
76
hoangtuaotrang_hp_vn
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom