根据屏幕分辨率调整工作表缩放级别

Question

我有一个用于根据屏幕分辨率调整屏幕缩放的Excel 2003宏。

Sub Macro1()
   Dim maxWidth As Long, myWidth As Long
   Dim myZoom As Single

   maxWidth = Application.UsableWidth * 0.96
   'I use r because upto r i have macro buttons
   myWidth = ThisWorkbook.ActiveSheet.Range("r1").Left
   myZoom = maxWidth / myWidth
   ActiveWindow.Zoom = myZoom * 100
End Sub

当我在Excel 2003中尝试时，按钮的大小和标题不能很好地缩放。而且无论屏幕分辨率是1024x768还是1366x768，Application.UsableWidth始终返回1026作为宽度。有什么想法吗？

我希望Excel工作表在任何系统屏幕分辨率下打开时都能适应宽度。

- logan

Answer 1

Sheets(1).Range("a1:AC1").Select
ActiveWindow.Zoom = True

是的，这就是所需的全部内容。这将根据屏幕分辨率调整缩放级别。 有关详细信息，请参阅下面链接 :- http://optionexplicitvba.blogspot.sg/2011/10/one-size-fits-all.html

- user2598456

---

欢迎来到SO。感谢您包含源代码，给您点赞。 - dic19

Answer 2

您可以向您的代码中添加此Windows API调用，以确定屏幕分辨率。

Private Declare PtrSafe Function GetSystemMetrics Lib "USER32" _
 (ByVal nIndex As Long) As Long

  Sub Macro1()
    Dim maxWidth As Long
    Dim myWidth As Long
    Dim myZoom As Single

    maxWidth = GetSystemMetrics(0) * 0.96
    myWidth = ThisWorkbook.ActiveSheet.Range("R1").Left
    myZoom = maxWidth / myWidth
    ActiveWindow.Zoom = myZoom * 100

  End Sub

- Robert Mearns

---

在 Excel 2003 中使用“PtrSafe”关键字有什么理由吗？ - JimmyPena

不，这只需要64位系统。 - Robert Mearns

Answer 3

我想分享一下我所编写的代码，它可以用于多个工作表。它借鉴了上面的答案，并且您不必指定活动范围是什么。

Sub Zoomitgood()

'this macro will loop through all the sheets and zoom to fit the contents by 
'measuring the width and height of each sheet. It will then zoom to 90% of 
'the "zoom to fit" setting.


    Dim WS_Count As Integer
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim maxwidth As Integer
    Dim width As Integer
    Dim Height As Integer
    Dim MaxHeight As Integer
    Dim zoom As Integer

'First Loop: Loop through each sheet, select each sheet so that each width 
'and height can be measured. The width and height are measured in number of 
'cells.

WS_Count = ActiveWorkbook.Worksheets.Count

For i = 1 To WS_Count

Worksheets(i).Activate
maxwidth = 0
MaxHeight = 0

'Second loop: measure the width of each sheet by running line by line and 
'finding the rightmost cell. The maximum value of the rightmost cell will be 
'set to the maxwidth variable

For j = 1 To 100
width = Cells(j, 100).End(xlToLeft).Column
If width >= maxwidth Then

maxwidth = width

End If

Next

'Third loop: measure the height of each sheet by running line by line and 
'finding the rightmost cell. The maximum value of the lowest cell will be 
'set to the maxheight variable.

For k = 1 To 100
Height = Cells(100, k).End(xlUp).Row
If Height >= MaxHeight Then

MaxHeight = Height

End If

Next

'Finally, back to loop 1, select the range for zooming. Then set the zoom to 
'90% of full zoom.

Range(Cells(1, 1), Cells(MaxHeight, maxwidth)).Select
ActiveWindow.zoom = True
zoom = ActiveWindow.zoom
ActiveWindow.zoom = zoom * 0.9
Cells(1000, 1000).Select
Application.CutCopyMode = False
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1

Next

MsgBox "You have been zoomed"


Application.ScreenUpdating = True
Application.DisplayAlerts = True



 End Sub

- Mike