Thiết kế UserForm bài số 11: Zoom UserForm

[Euler]

Bài học thiết kế số 01

Bạn cần đăng nhập để thấy link

Bài học thiết kế số 02

Bạn cần đăng nhập để thấy link

Bài học thiết kế số 03

Bạn cần đăng nhập để thấy link

.
Bài học thiết kế số 04

Bạn cần đăng nhập để thấy link

.
Bài học thiết kế số 05

Bạn cần đăng nhập để thấy link

.
Bài học thiết kế số 06

Bạn cần đăng nhập để thấy link

.
Bài học thiết kế số 07

Bạn cần đăng nhập để thấy link

.
Bài học thiết kế số 08

Bạn cần đăng nhập để thấy link

.
Bài học thiết kế số 09

Bạn cần đăng nhập để thấy link

.
Bài học thiết kế số 10

Bạn cần đăng nhập để thấy link

.
____________________________
Bài viết này đang xin phép tác giả Duy Tuân. Tôi nghĩ không có vấn đề gì vì tác giả đã công khai trên GPE.
Nếu có phản hồi không đồng ý, chúng tôi sẽ gỡ bỏ bài viết này khỏi diễn đàn tuhocvba.net

'****************************************************
'Author: Nguyen Duy Tuan - www.bluesofts.net
'****************************************************
'Nguon tham khao: https://www.giaiphapexcel.com/diendan/threads/zoom-userform-controls.52745/

Mục đích: Chúng ta muốn phóng to UserForm.
Đôi khi chúng ta gặp người dùng mà họ dùng máy laptop, hiển thị UserForm khiến cho họ khó nhìn và họ có mong muốn phóng to UserForm ra. Đây là đòi hỏi đã có trong thực tế.

Code dưới đây, được Nguyễn Duy Tuân xây dựng, sử dụng các hàm API phức tạp, với người mới học, tôi nghĩ có thể chưa cần lý giải. Vì vậy trong file demo, tôi làm tối giản nhất có thể để các bạn có thể áp dụng vào file của các bạn được ngay.

Phần code:

Option Explicit
'****************************************************
'Author: Nguyen Duy Tuan - www.bluesofts.net
'****************************************************
'Nguon tham khao: https://www.giaiphapexcel.com/diendan/threads/zoom-userform-controls.52745/
'Khai bao API
#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
      (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
      
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
      (ByVal lpClassName As String, ByVal lpWindowName As String) 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
#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 = WS_THICKFRAME
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MINIMIZE = &H20000000

Private Const ZoomMin = 10 'VBA cho phep thap nhat
Private Const ZoomMax = 400 'VBA cho phep muc cao nhat. Ban co the tu thay doi ZoomMin va ZoomMax trong pham vi 10-400

Dim hWnd&, PrevStyle&
Dim OldWidth As Double, OldHeight As Double
Dim AllowResize As Boolean

Private Sub UserForm_Initialize()
    AllowResize = True
    OldWidth = Width
    OldHeight = Height
    If Val(Application.Version) < 9 Then
        hWnd = FindWindow("ThunderXFrame", Caption)  'XL97
    Else
        hWnd = FindWindow("ThunderDFrame", Caption)  'XL2000
    End If

    PrevStyle = GetWindowLong(hWnd, GWL_STYLE)
    SetWindowLong hWnd, GWL_STYLE, PrevStyle _
                                Or WS_SIZEBOX _
                                Or WS_MINIMIZEBOX _
                                Or WS_MAXIMIZEBOX
    
End Sub

Private Sub UserForm_Terminate()
    SetWindowLong hWnd, GWL_STYLE, PrevStyle
End Sub

Private Sub UserForm_Resize()
    Dim tmpZoom As Long
    If Not AllowResize Then Exit Sub
    tmpZoom = Round(Width / OldWidth * 100, 0)
    If tmpZoom < ZoomMin Then tmpZoom = ZoomMin
    If tmpZoom > ZoomMax Then tmpZoom = ZoomMax
    If tmpZoom = ZoomMin Or tmpZoom = ZoomMax Then
        'Neu khong phai la phong to man hinh thi co lai kich co
        If Not (GetWindowLong(hWnd, GWL_STYLE) And WS_MAXIMIZE) = WS_MAXIMIZE Then
            AllowResize = False 'Ngan khong chay UserForm_Resize khi dang thay doi size
            Width = tmpZoom * OldWidth / 100
            Height = Width * OldHeight / OldWidth
            AllowResize = True 'Cho phep resize
        End If
    End If
    Zoom = tmpZoom
End Sub

Private Sub cmdCLose_Click()
    Unload Me
End Sub

Trình diễn:

Bạn cần đăng nhập để thấy đính kèm

File demo:

Bạn cần đăng nhập để thấy link

 

[maiban2068]

Cảm giác code #1 khá mượt.
Ở đây cũng có chủ đề tương tự:

Bạn cần đăng nhập để thấy link

Tuy nhiên dùng thử thì cảm giác hơi giật, code thì dài kinh khủng.