CODEWITHSUNDEEP
excelvbascreen-resolutionexcel-2003
logan
logan

Reputation: 8346

Adjusting worksheet zoom level based on screen resolution

I have an Excel 2003 macro to adjust my screen zoom based on the screen resolution.

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

When I try in Excel 2003, button size & its caption are not zooming properly. And Application.UsableWidth is always returning 1026 as width for either the screen resolution 1024*768 or 1366*768. Any ideas?

I want the Excel sheet to be fit in width if open in any system screen resolution

Upvotes: 5

Views: 22949

Answers (3)

Mike
Mike

Reputation: 1

I thought I'd share what I put together which can be used for multiple sheets. It borrows from the above answers, and you do not have to specify what the active range is 

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

Upvotes: 0

user2598456
user2598456

Reputation: 111

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

Yes, this is all that's required. This will adjust the zoom level based on the screen resolution. Refer below link for detailed information :- http://optionexplicitvba.blogspot.sg/2011/10/one-size-fits-all.html

Upvotes: 11

Robert Mearns
Robert Mearns

Reputation: 11986

You can add this Windows API call to your code which can determine the screen resolution.

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

Upvotes: 4

Related Questions