Can we relate worksheet area to minitor size?

[Caula]

Hi,

Is there any way I can adjust the relative size of the viewable area of a worksheet at opening according to the monitor size?

I want it to zoom in and out according to monitor size while keeping a pre-defined viewable area in proportion with the monitor size. This might mean adjusting column widths and row heights if need be. Any ideas?

Thanks,

Caula

 

[bensonsearch]

HI,
I have seen examples for userforms (not all work). My quess would be something using vba and application.width, application.height and also zoom ()

 

[doofusboy]

You need to be tracking screen resolution, not monitor size. This is because 2 people with same monitor size may indeed have set quite different screen resolutions. Used to do this in VB6.0, if I have time today I'll try to find some code in my snippets 'library'.

 

[Gary McMaster]

Here's a snip that will return the resolution:

Option Explicit

Declare Function GetSystemMetrics32 Lib "User32" _
Alias "GetSystemMetrics" (ByVal nIndex&) As Long


Public Sub Test()

MsgBox GetSystemMetrics32(0) & " x " & GetSystemMetrics32(1)

End Sub

 

[Jaafar Tribak]

You could use something along these lines this but the result won't be very sharp :

Adjust the viewable sheet area to the range A1:K20

Sheet1.Activate
Sheet1.Range("a1:k20").Select
ActiveWindow.Zoom = True

 

[Jaafar Tribak]

Here is a different approach which uses some GDI APIs to fit the Range of your choice EXACTLY to the entire viewable area of the worksheet regardless of the screen resolution,zoom, rows/colummns dimensions etc...

Put this in a Standard Module :

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function GetDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32.dll" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long

Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) As Long

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const PointsPerInch = 72


Public Sub FitRangeToScreen(ByVal Rng As Range)

    Dim tPt  As POINTAPI
    Dim oObj As Object
    Dim oCell As Range
    Dim ScrLeftToRangeRight As Variant
    Dim ScrTopToRangeBottom As Variant
    
    On Error Resume Next
    
    Rng.Parent.Activate
    Rng.Select
    ActiveWindow.Zoom = True
    
    Do
        For Each oCell In Rng.Rows(1).Cells
        
            oCell.EntireColumn.ColumnWidth = oCell.EntireColumn.ColumnWidth + 0.5
            ScrLeftToRangeRight = Rng.Left + Rng.Width
            
            With ActiveWindow
            
                tPt.x = PTtoPX(ScrLeftToRangeRight * .Zoom / 100, False) _
                + .PointsToScreenPixelsX(0)
                
                tPt.y = PTtoPX(Rng.Top * .Zoom / 100, True) _
                + .PointsToScreenPixelsY(0)
                
                Set oObj = .RangeFromPoint(tPt.x, tPt.y)
            
            End With
            
            If TypeName(oObj) <> "Range" Then MsgBox "Width adjusted.": Exit Do
            
'            DoEvents
            
        Next
        
'        DoEvents
    Loop
    
    InvalidateRect 0, 0, 0
    
    Do
        For Each oCell In Rng.Columns(1).Cells
        
            oCell.EntireRow.RowHeight = oCell.EntireRow.RowHeight + 0.5
            ScrTopToRangeBottom = Rng.Top + Rng.Height
            
            With ActiveWindow
            
                tPt.x = PTtoPX(Rng.Left * .Zoom / 100, False) + _
                .PointsToScreenPixelsX(0)
                
                tPt.y = PTtoPX(ScrTopToRangeBottom * .Zoom / 100, True) + _
                .PointsToScreenPixelsY(0)
                
                Set oObj = .RangeFromPoint(tPt.x, tPt.y)
                
            End With
            
            If TypeName(oObj) <> "Range" Then MsgBox "Height adjusted.": Exit Do
            
'            DoEvents
            
        Next
        
'        DoEvents
    Loop
    
    InvalidateRect 0, 0, 0

End Sub


Private Function ScreenDPI(bVert As Boolean) As Long
 
   Static lDPI(1), lDC
   
   If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
 
End Function
 
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
 
    PTtoPX = Points * ScreenDPI(bVert) / PointsPerInch
 
End Function

Usage :

Put this in the workbook module to fit the Range "A1:G10" of sheet1 to the entire sheet wiewable area each time the workbook is opened :

Private Sub Workbook_Open()

    Call FitRangeToScreen(Sheet1.Range("A1:G10"))

End Sub