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

我有一个Excel 2003macros来调整我的屏幕缩放基于屏幕分辨率。

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

当我在Excel 2003中尝试时，button大小及其标题不能正确缩放。 和Application.UsableWidth始终返回1026作为宽度为屏幕分辨率1024 * 768或1366 * 768。 有任何想法吗？

如果打开任何系统屏幕分辨率，我希望Excel表格适合宽度

Answer 1

您可以将此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 

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