返回列表 上一主題 發帖

[發問] Userform最大化(且內容比例自動放大?)

[發問] Userform最大化(且內容比例自動放大?)

本帖最後由 PKKO 於 2015-5-13 17:47 編輯

小弟已知Userform 最大化的程式碼,也知道依比率放大的程式碼,但不知道如何自動取得兩者之間的比率,來自動設定放大的倍數...
有人知道zoom的比率要如何求得嗎?

比率的程式碼
UserForm1.Zoom = 125

最大化的程式碼
  1. Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
  2. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  3. Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
  4. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  5. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  6. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  7. Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
  8. Private Const WS_MAXIMIZEBOX = &H10000
  9. Private Const WS_MINIMIZEBOX = &H20000
  10. Private Const GWL_STYLE = (-16)
  11. Private Const SW_SHOWMAXIMIZED = 3
  12. Private Const SW_SHOWNORMAL = 1
  13. Private Const SW_SHOWMINIMIZED = 2
  14. Private Const WS_THICKFRAME = &H40000
  15. Const SM_CXFULLSCREEN = 16
  16. Const SM_CYFULLSCREEN = 17
  17. Const HWND_TOPMOST = -1
  18. Const SWP_SHOWWINDOW = &H40
  19. Dim hWndForm As Long
  20. Dim IStyle As Long

  21. Private Sub UserForm_Initialize()
  22.   hWndForm = FindWindow("ThunderDFrame", Me.Caption)
  23.   IStyle = GetWindowLong(hWndForm, GWL_STYLE)
  24.   IStyle = IStyle Or WS_THICKFRAME
  25.   IStyle = IStyle Or WS_MINIMIZEBOX
  26.   IStyle = IStyle Or WS_MAXIMIZEBOX
  27.   SetWindowLong hWndForm, GWL_STYLE, IStyle
  28. End Sub

  29. Public Sub myShowMax()
  30.    
  31.     SetActiveWindow hWndForm
  32.     ShowWindow hWndForm, SW_SHOWMAXIMIZED
  33. End Sub
複製代碼
PKKO

我也第一次用ZOOM
發現它有缺陷, 寬高只能同放大或縮小, 不能一邊放大另一邊縮小
只好遷就它

// ================

Dim Form_First_wh
Dim Form_Last_wh

   
    Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function SetActiveWindow Lib "user32" (ByVal hWnd As Long) 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Const WS_MAXIMIZEBOX = &H10000
    Private Const WS_MINIMIZEBOX = &H20000
    Private Const GWL_STYLE = (-16)
    Private Const SW_SHOWMAXIMIZED = 3
    Private Const SW_SHOWNORMAL = 1
    Private Const SW_SHOWMINIMIZED = 2
    Private Const WS_THICKFRAME = &H40000
    Const SM_CXFULLSCREEN = 16
    Const SM_CYFULLSCREEN = 17
    Const HWND_TOPMOST = -1
    Const SWP_SHOWWINDOW = &H40
    Dim hWndForm As Long
    Dim IStyle As Long




    Private Sub UserForm_Initialize()
      hWndForm = FindWindow("ThunderDFrame", Me.Caption)
      IStyle = GetWindowLong(hWndForm, GWL_STYLE)
      IStyle = IStyle Or WS_THICKFRAME
      IStyle = IStyle Or WS_MINIMIZEBOX
      IStyle = IStyle Or WS_MAXIMIZEBOX
      
      SetWindowLong hWndForm, GWL_STYLE, IStyle
      
      Form_First_wh = Array(UserForm1.Width, UserForm1.Height)
      Form_Last_wh = Form_First_wh
    End Sub

    Public Sub myShowMax()
        SetActiveWindow hWndForm
        ShowWindow hWndForm, SW_SHOWMAXIMIZED
    End Sub

Private Sub UserForm_Resize()
If (Form_First_wh(1) - UserForm1.Height) * (Form_First_wh(0) - UserForm1.Width) < 0 Then
     MsgBox "UserForm1.Zoom 無法支援視窗一邊放大, 另一邊卻縮小"
     UserForm1.Move UserForm1.Left, UserForm1.Top, Form_Last_wh(0), Form_Last_wh(1)
     Exit Sub
End If

On Error Resume Next
If Abs(Form_First_wh(1) - UserForm1.Height) > Abs(Form_First_wh(0) - UserForm1.Width) Then
     UserForm1.Width = UserForm1.Height / Form_First_wh(1) * Form_First_wh(0)
Else
    UserForm1.Height = UserForm1.Width / Form_First_wh(0) * Form_First_wh(1)
End If
On Error GoTo 0

   Form_Last_wh = Array(UserForm1.Width, UserForm1.Height)
UserForm1.Zoom = UserForm1.Height / Form_First_wh(1) * 100
End Sub

TOP

回復 2# bobomi

大大好威~

感謝回復,經測試後21"螢幕可正常使用

反倒是筆電的13"螢幕會變成太大,有辦法依照比例自動放大或是縮小嗎?
PKKO

TOP

本帖最後由 bobomi 於 2015-5-17 12:04 編輯

我拿到13吋筆電試
比例好像ok耶
但是筆電有開視覺特效
才發現我的寫法會因為視覺特效一直刷新螢幕
導致 UserForm1 出現顫抖 ( 桌機沒開視覺特效 , 不會有這問題 )

所以你改成這樣看看
不去修改UserForm1 寬高, 使其自由度最大
但缺點你拉拉看就知道了
這問題出在  ZOOM 寬高只能同放大或縮小, 不能一邊放大另一邊縮小
不然 code 只要2行就解決了

(1)
Private Sub UserForm_Resize()
On Error Resume Next
UserForm1.Zoom = UserForm1.Height / Form_First_wh(1) * 100
End Sub
(2)
Private Sub UserForm_Resize()
On Error Resume Next
UserForm1.Zoom = UserForm1.Width / Form_First_wh(0) * 100
End Sub
(1) (2) 分別測試一下, 看看哪個比較適合

TOP

如果還是不行
把 UserForm1 的程式碼刪光(只留控制項就可以了 )
然後匯出 UserForm1  -> 上傳 UserForm1.frm
我再拉拉看為何不行

TOP

本帖最後由 bobomi 於 2015-5-17 14:30 編輯

改成下面的 code  (有發現問題在哪了)
看看筆電的13"螢幕問題是否改善
========================
Dim Form_First_wh
Dim Form_Last_wh
Dim UserForm1_BarHeight

   
    Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function SetActiveWindow Lib "user32" (ByVal hWnd As Long) 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Const WS_MAXIMIZEBOX = &H10000
    Private Const WS_MINIMIZEBOX = &H20000
    Private Const GWL_STYLE = (-16)
    Private Const SW_SHOWMAXIMIZED = 3
    Private Const SW_SHOWNORMAL = 1
    Private Const SW_SHOWMINIMIZED = 2
    Private Const WS_THICKFRAME = &H40000
    Const SM_CXFULLSCREEN = 16
    Const SM_CYFULLSCREEN = 17
    Const HWND_TOPMOST = -1
    Const SWP_SHOWWINDOW = &H40
    Dim hWndForm As Long
    Dim IStyle As Long


    Private Sub UserForm_Initialize()
      hWndForm = FindWindow("ThunderDFrame", Me.Caption)
      IStyle = GetWindowLong(hWndForm, GWL_STYLE)
      IStyle = IStyle Or WS_THICKFRAME
      IStyle = IStyle Or WS_MINIMIZEBOX
      IStyle = IStyle Or WS_MAXIMIZEBOX
      
      SetWindowLong hWndForm, GWL_STYLE, IStyle
      
      
      a = UserForm1.Height
      UserForm1.Height = 0
      UserForm1_BarHeight = UserForm1.Height
      UserForm1.Height = a + 1.5
      
      Form_First_wh = Array(UserForm1.Width, UserForm1.Height)
      Form_Last_wh = Form_First_wh
    End Sub

    Public Sub myShowMax()
        SetActiveWindow hWndForm
        ShowWindow hWndForm, SW_SHOWMAXIMIZED
    End Sub

Private Sub UserForm_Resize()
If Not IsArray(Form_First_wh) Then Exit Sub
' If (Form_First_wh(1) - UserForm1.Height) * (Form_First_wh(0) - UserForm1.Width) < 0 Then
'     MsgBox "UserForm1.Zoom 無法支援視窗一邊放大, 另一邊卻縮小"
'     UserForm1.Move UserForm1.Left, UserForm1.Top, Form_Last_wh(0), Form_Last_wh(1)
'     Exit Sub
' End If

On Error Resume Next
If Abs(Form_First_wh(1) - UserForm1.Height) > Abs(Form_First_wh(0) - UserForm1.Width) Then
     UserForm1.Width = (UserForm1.Height - UserForm1_BarHeight) / (Form_First_wh(1) - UserForm1_BarHeight) * Form_First_wh(0)
Else
    UserForm1.Height = UserForm1.Width / Form_First_wh(0) * (Form_First_wh(1) - UserForm1_BarHeight) + UserForm1_BarHeight
   'UserForm1.Height = UserForm1.Width / Form_First_wh(0) * Form_First_wh(1)
End If
On Error GoTo 0

   Form_Last_wh = Array(UserForm1.Width, UserForm1.Height)
On Error Resume Next
UserForm1.Zoom = (UserForm1.Height - UserForm1_BarHeight) / (Form_First_wh(1) - UserForm1_BarHeight) * 100
End Sub

TOP

還有一個方法, 就是不要用 ZOOM , 改成自己縮放

TOP

Zoom  比較好的方案
22.zip (12.39 KB)

TOP

回復 8# bobomi


    感謝大大的用心! 我測試完再跟您報告 !
PKKO

TOP

本帖最後由 GBKEE 於 2015-5-18 10:05 編輯

回復 9# PKKO
試試看自己縮放.
這表單的程式碼
  1. Option Explicit
  2. Dim X As Double, Y As Double, e As Control
  3. Private Sub UserForm_Initialize()  '表單初始化的程式
  4.     Dim e As Control
  5.     X = Width
  6.     Y = Height
  7.     For Each e In Me.Controls
  8.         e.Tag = e.Top & "," & e.Left & "," & e.Width & "," & e.Height & "," & e.Font.Size
  9.     Next
  10. End Sub
  11. Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  12. '發生在當使用者按了滑鼠鍵時。MouseDown 發生於使用者按下滑鼠鍵****
  13.     Dim xZoom As Double
  14.     If Shift = 2 Then           'Ctrl 鍵
  15.         Select Case Button      '滑鼠
  16.             Case 1              '按下左滑鼠鍵。: 放大
  17.                 xZoom = 1.2     '放大 %2
  18.             Case 2              '按下右滑鼠鍵。: 縮小
  19.                 xZoom = 0.8     '所小 %2
  20.         End Select
  21.         Zoom_UserForm xZoom     '表單縮放程式
  22.     ElseIf Shift = 1 Then       'Shift 鍵 +任一滑鼠按鍵
  23.         Revert_UserForm         '表單還原原本大小
  24.     End If
  25. End Sub
  26. Private Sub Zoom_UserForm(xZoom As Double)  '表單縮放
  27.     Width = Width * xZoom
  28.     Height = Height * xZoom
  29.     For Each e In Controls
  30.         With e
  31.             .Top = .Top * xZoom
  32.             .Left = .Left * xZoom
  33.             .Width = .Width * xZoom
  34.             .Height = .Height * xZoom
  35.             .Font.Size = .Font.Size * xZoom
  36.         End With
  37.     Next
  38. End Sub
  39. Private Sub Revert_UserForm() '表單還原原本大小
  40.     Dim xTag As Variant
  41.     Width = X
  42.     Height = Y
  43.     For Each e In Me.Controls
  44.         With e
  45.             xTag = Split(.Tag, ",")
  46.             .Top = xTag(0)
  47.             .Left = xTag(1)
  48.             .Width = xTag(2)
  49.             .Height = xTag(3)
  50.             .Font.Size = xTag(4)
  51.         End With
  52.     Next
  53. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 地上種了菜,就不易長草;心中有善,就不易生惡。
返回列表 上一主題