基于屏幕分辨率调整工作表缩放级别

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中，按钮的大小&其标题不正确缩放。 和Application.UsableWidth总是返回1026作为屏幕分辨率1024 * 768或1366 * 768的宽度。有任何想法吗？

我想，如果在任何系统的屏幕分辨率

Answer 1

您可以添加此Windows API调用你的代码，可以判断屏幕分辨率打开Excel工作表要适合宽。

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 

Answer 2

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

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

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