GBKEE

回復 19# PKKO
直接放大

1. Option Explicit
   
2. Dim Form_Tag As Variant
   
3. Private Sub UserForm_Initialize()  '表單初始化的程式
   
4.     Dim e As Control
   
5.     Form_Tag = Split(Top & "," & Left & "," & Width & "," & Height & "," & Font.Size, ",")
   
6.     Form_xlMax
   
7. End Sub
   
8. Private Sub Form_xlMax() '表單最大化
   
9.     Dim xZoom As Double, yZoom As Double, e As Control
   
10.     With Application
    
11.         .WindowState = xlMaximized
    
12.         xZoom = .Width / Form_Tag(2)    '寬放大的比例
    
13.         yZoom = .Height / Form_Tag(3)   '高放大的比例
    
14.     End With
    
15.     Top = 0
    
16.     Left = 0
    
17.     Width = Width * xZoom
    
18.     Height = Height * yZoom
    
19.     For Each e In Controls
    
20.         With e
    
21.             .Top = .Top * xZoom
    
22.             .Left = .Left * xZoom
    
23.             .Width = .Width * xZoom
    
24.             .Height = .Height * yZoom
    
25.             .Font.Size = .Font.Size * xZoom
    
26.         End With
    
27.     Next
    
28. End Sub

複製代碼

PKKO

回復 20# bobomi


    比例上還是會有點奇怪,放到最大時,右邊會有多餘的空間,不過沒關係,已經很感謝妳囉!

PKKO

回復 21# GBKEE


    感謝超版大大,這個超好用的了(而且程式碼很簡短)
只是表單偵測的高度部分,他會偵測整個螢幕的高度
無法只偵測到工作列的高度就好

導致工作列的位置會蓋掉userform的顯示
不過不打緊,userfrom最下方不要放元件就好!

bobomi

回復 23# PKKO

zoom 就只能這樣 (它的寬高都只能是相同比例)
要想 下邊的控件不會過頭, 那麼右邊就會有多餘的空間  
要想右邊沒有多餘的空間 , 那麼下邊的控件就會過頭

自己縮放沒有上面問題 ( 但是字型無法完美縮放  )
終極一點  自己縮放 + Zoom 混搭 -> 字型可以較完美縮放

bobomi

1.zip (2.71 KB)

下載次數: 8

2015-5-21 21:18

這樣還會蓋到嗎?

GBKEE

回復 24# PKKO
導致工作列的位置會蓋掉userform的顯示
不過不打緊,userfrom最下方不要放元件就好!

這樣可以嗎?

1. Option Explicit
   
2. Dim Form_Tag As Variant
   
3. Private Sub UserForm_Activate()
   
4.     Form_xlMax
   
5. End Sub
   
6. Private Sub Form_xlMax() '表單最大化
   
7.     Dim xZoom As Double, yZoom As Double, e As Control
   
8.     With Application
   
9.         .WindowState = xlMaximized
   
10.         xZoom = .Width / Me.Width     '寬放大的比例
    
11.         '****************
    
12.         yZoom = .Height / (Me.Height + 20)  '高放大的比例
    
13.         '****************
    
14.     End With
    
15.     Top = 0
    
16.     Left = 0
    
17.     Width = Width * xZoom
    
18.     Height = Height * yZoom
    
19.     For Each e In Controls
    
20.         With e
    
21.             .Top = .Top * xZoom
    
22.             .Left = .Left * xZoom
    
23.             .Width = .Width * xZoom
    
24.             .Height = .Height * yZoom
    
25.             .Font.Size = .Font.Size * yZoom
    
26.         End With
    
27.     Next
    
28. End Sub

複製代碼

bobomi

這樣還會蓋到嗎?
bobomi 發表於 2015-5-21 21:18

  奇怪咧!!  我匯出的檔案為何不是沒更新, 不然就是沒有 UseForm
重新上傳

自縮.zip (22.41 KB)

下載次數: 21

2015-5-22 07:23

stillfish00

回復 28# bobomi
原來 VBA 有GetSetting、SaveSetting 可以存取註冊表
學到了~

下載 (56.94 KB)

2015-5-22 14:12

PKKO

回復 26# GBKEE

超版大大,確實視窗已經到工作列上方了

可是...
1.比例不對,原本對齊在水平線上的兩個元件,會變成一上一下
2.雖然視窗跑到工作列上方了,可是內容並沒有壓縮,導致原本要顯示的元件,無法顯示出來(被邊界卡掉了)

PKKO

回復 27# bobomi


    大大,我只能說您太神了!
這個自己拉的方式非常棒!
優點如下:
一、比妳之前的只有拉高度才會變更比例的好
二、可以有儲存功能
三、比例即便有問題也可以解決(文字原本顯示四個字,只有出現三個字,現在也可自行靠拉寬一點就顯示出來正確比例,所以四個字都可以顯示)

目前嘗試之後發現以下問題
1.若是有變更ListBox並且,自動調整欄位時,程式碼會崩潰在下方開頭的位置

1. ocx.Left = ocx_xy(0) * Rw
   
2. ocx.Top = ocx_xy(1) * Rh
   
3. ocx.Width = ocx_xy(2) * Rw
   
4. ocx.Height = ocx_xy(3) * Rh

複製代碼

A:我目前已有簡陋的解決方式,在啟動更新listBox 的時候checkUpdate = True
然後在Private Sub UserForm_Layout() 的第一行輸入    If checkUpdate = True Then checkUpdate = False: Exit Sub
這樣更新listBox的時候就不會執行,等到listbox結束之後他又會再更新一次畫面就OK了,因次第一個問題得到一個完美但簡陋的解決方式
附上我自己寫的listbox 快速使用程式碼

1. Function LIST顯示(UserForm, LISTBOX, RNG)
   
2.         checkUpdate = True
   
3.         '將資料顯示在LISTBOX 上
   
4.         LISTBOX.ColumnCount = UBound(RNG, 2)
   
5.         LISTBOX.List = RNG 'ListBox 的顯示方式
   
6.         '自動調整的程式
   
7.         '新增以下code
   
8.         Dim sWidth As String, dTotal As Double
   
9.         Dim oTemp As Object
   
10.         
    
11.         Set oTemp = UserForm.Controls.Add("Forms.TextBox.1")
    
12.         With oTemp
    
13.           .AutoSize = True'在這行程式碼的地方會啟動Private Sub UserForm_Layout()導致錯誤
    
14.           .MultiLine = True
    
15.           .WordWrap = False
    
16.           .SelectionMargin = False
    
17.           .Font.Name = LISTBOX.Font.Name
    
18.           .Font.Size = LISTBOX.Font.Size
    
19.         End With
    
20.         
    
21.         For j = 0 To LISTBOX.ColumnCount - 1
    
22.           oTemp.Text = ""
    
23.           For i = 0 To LISTBOX.ListCount - 1
    
24.             oTemp.Text = oTemp.Text & LISTBOX.List(i, j) & vbCr
    
25.           Next
    
26.           dTotal = dTotal + oTemp.Width
    
27.           sWidth = sWidth & oTemp.Width + 10 & ";"
    
28.         Next
    
29.         UserForm.Controls.Remove oTemp.Name
    
30.         LISTBOX.ColumnWidths = sWidth
    
31. End Function

複製代碼

2.若我有4個userForm,要如何自動存取同一個GetSetting、SaveSetting,讓四個視窗的大小都會相同
A:目前我還在研究這個部分