Solved

Excel VBA - Query for Screen Resolution of a Laptop

Posted on 2013-02-02
3
628 Views
Last Modified: 2013-03-01
Hi,

Is there an Excel  VBA code that I could query the screen resolution of a laptop  ( e.g. 1366 x 768 )  when I fire up a workbook from it ?

Is so, would appreciate your help with the vba code.


Thanks
0
Comment
Question by:Russellbrown
3 Comments
 
LVL 10

Accepted Solution

by:
broro183 earned 125 total points
ID: 38846467
hi Russell,

Does this do what you want?

'sourced from http://www.mrexcel.com/forum/excel-questions/61607-checking-changing-screen-resolution-visual-basic-applications.html#post288534
'32-bit API declaration
Declare Function GetSystemMetrics Lib "user32" _
  (ByVal nIndex As Long) As Long

Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1

Sub DisplayVideoInfo()
    vidWidth = GetSystemMetrics(SM_CXSCREEN)
    vidHeight = GetSystemMetrics(SM_CYSCREEN)
    
    If vidWidth = 1024 And vidHeight = 768 Then
        Exit Sub
    Else
        Ans = MsgBox("The Current Video mode is:" & vidWidth & " X " & vidHeight & vbCrLf _
        & "S.T.A.R.S. is designed to be viewed at 1024 X 768" & vbCrLf _
        & "Please goto Start-->Control Panel-->Display-->Settings" & vbCrLf _
        & "and adjust your screen area accordingly." _
        , vbCritical, "Insufficient Video Settings")
    End If

End Sub

Open in new window


This page also shows a line of code to open up the dialogbox to change the resolution.

hth
Rob
0
 
LVL 1

Assisted Solution

by:cben
cben earned 125 total points
ID: 38848355
Hi
I have long used a code, probably based on the Mr Excel one above, to adjust the zoom on the workbook sheets according to the display.
Call it in the
Option Explicit

'32-bit API declaration
Declare Function GetSystemMetrics Lib "user32" _
  (ByVal nIndex As Long) As Long

Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1



Sub SetZoomByVideo()
    Dim vidWidth As Long, vidHeight As Long
    Dim Msg As String
    Dim ZoomVal As Integer
    Dim SheetNames() As String
    Dim SheetHidden() As Boolean
    Dim i As Integer
    Dim SheetCount As Integer
    Dim VisibleWins As Integer
    Dim Item As Object
    Dim OldActive As Object
   
    vidWidth = GetSystemMetrics(SM_CXSCREEN)
    ' Check if not same as previous opening so no change needed.
    If vidWidth = Range("Video") Then GoTo Out
    vidHeight = GetSystemMetrics(SM_CYSCREEN)
    Msg = "The current video mode is: "
    Msg = Msg & vidWidth & " X " & vidHeight
    MsgBox Msg
    
     '   Turn off screen updating
     Application.ScreenUpdating = False
    ' Table to adjust to new screen resolutions
    ' Manual change to fix values
    
    If vidWidth < 799 Then ZoomVal = 65
    If vidWidth >= 800 Then ZoomVal = 75
    If vidWidth >= 1024 Then ZoomVal = 100
    If vidWidth >= 1152 Then ZoomVal = 100
    If vidWidth >= 1279 Then ZoomVal = 120
     If vidWidth >= 1280 Then ZoomVal = 120
     On Error Resume Next
    Sheet4.Unprotect Password:=pw
    

    Range("Video") = vidWidth
    Range("Zoom") = ZoomVal
     Sheet4.Protect Password:=pw, UserInterfaceOnly:=True
On Error GoTo 0
'   Sets zoom of sheets active workbook.
      
        
    If ActiveWorkbook Is Nothing Then Exit Sub ' No active workbook
    SheetCount = ActiveWorkbook.Sheets.Count
   
    
'   Check for protected workbook structure
    If ActiveWorkbook.ProtectStructure Then
        MsgBox ActiveWorkbook.Name & " is protected.", _
           vbCritical, "Cannot Zoom Sheets."
        Exit Sub
    End If

'   Disable Ctrl+Break
    Application.EnableCancelKey = xlDisabled
       
'   Get the number of sheets
    SheetCount = ActiveWorkbook.Sheets.Count
    
'   Redimension the arrays
    ReDim SheetNames(1 To SheetCount)
    ReDim SheetHidden(1 To SheetCount)

'   Store a reference to the active sheet
    Set OldActive = ActiveSheet
   
'   Put sheet names into array
     For i = 1 To SheetCount
        
           SheetNames(i) = ActiveWorkbook.Sheets(i).Name
       
    Next i
   
'   Fill array with hidden status of sheets
    For i = 1 To SheetCount
        SheetHidden(i) = Not ActiveWorkbook.Sheets(i).Visible
'       unhide hidden sheets
        If SheetHidden(i) Then ActiveWorkbook.Sheets(i).Visible = True
    Next i
    'For i = 1 To SheetCount
        'SheetNames(i) = ThisWorkbook.Sheets("ZoomSheet").Cells(i, 1)
    'Next i
   

    
'  Zoom the sheets
    For i = 1 To SheetCount
        Sheets(SheetNames(i)).Activate
        ActiveWindow.Zoom = ZoomVal
    Next i

'   Re-hide sheets
    For i = 1 To SheetCount
        If SheetHidden(i) Then ActiveWorkbook.Sheets(i).Visible = False
    Next i
  '  MsgBox "Zoom Setting has been reset to suit your screen at avalue of " & ZoomVal
    
'   Reactivate the original active sheet
    OldActive.Activate
Out:
    Application.ScreenUpdating = True
End Sub

Open in new window


Range Names in sheet Video & ZoomVal are used to store the previous settings and avoid the routine if same as before. pw is coded in password.

Hope this helps
0
 

Author Comment

by:Russellbrown
ID: 38849839
Hi both,

Thank you for the replies.  

1) obtaining the screen resolution - that is great and is working fine;

2) I will modfiy /  incorporate a code to execute the following:
    if resolution is <=800, then  me.zoom = 75
    if resolution is <=1066, then me.zoom = 85
    if resolution is <=1366, then me.zoom = 100 .........
*  ( since I am using Excel  userforms )


Wll revert with the results.

Many thanks and regards
0

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

As with any other System Center product, the installation for the Authoring Tool can be quite a pain sometimes. This article serves to help you avoid making these mistakes and hopefully save you a ton of time on troubleshooting :)  Step 1: Make sur…
This collection of functions covers all the normal rounding methods of just about any numeric value.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

809 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question