Screen Resolution?

[dan2]

Does anybody know if in VBA it is possible to make sure that on opening an excel document the screen resolution is set to say 800x600?

TIA

Dan

[Joe Was]

Try,

Sub GetScreenSize()
Dim x As Long, y As Long, sYourMessage, iConfirm As Integer
'x = GetSystemMetrics(SM_CXSCREEN)
'y = GetSystemMetrics(SM_CYSCREEN)
'If x < 1024 And y < 768 Then
'sYourMessage = "Current screen size is " & x & " x " & y & vbCrLf
sYourMessage = sYourMessage & "This screen is best viewed at 1024 x 768." & vbCrLf
sYourMessage = sYourMessage & "Would you like to change the resolution?"
iConfirm = MsgBox(sYourMessage, vbExclamation + vbYesNo, "Screen Resolution")
If iConfirm = vbYes Then
'Change screen settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3")
End If
'End If
End Sub

Some systems may not like this code. I use it and most systems take it. JSW

PS. It works by prompting the user to set the resolution to what ever, then it pulls up the windows Display utility, so the user can slide the resolution over if needed. JSW

[ This Message was edited by: Joe Was on 2002-03-28 06:50 ]

[Joe Was]

You may also try:

Worksheets("Sheet1").PageSetup.Zoom = 80

To set the sheet zoom to 80%. JSW

[dan2]

Works well thanks Joe

Is there a way of just setting the resolution to avoid the screen settings requester coming on the screen?

Thanks

Dan

[Joe Was]

Some time ago I did a macro that on open, got the current display resolution, comepaired it to the resolution wanted and if different saved the original resolution and set the current resolution to the resolution wanted. Then on exit it got the saved resolution and reset the current resolution to the original saved resolution.

I looked for the code but it must be on another system or I lost it. I cannot remember the trick to setting the resolution directly? JSW

[Ivan F Moala]

On 2002-03-28 17:11, dan2 wrote:
Works well thanks Joe

Is there a way of just setting the resolution to avoid the screen settings requester coming on the screen?

Thanks

Dan

Hi Dan
Here is a routine i got together that does
as Joe has said
ie. Changes scrn resolution open open then
restores upon close....had a bit of
trouble restoring the taskbar and app.wnd
but found a fix.

I could have placed the settings on a worksheet but opted to Keep the old values
in a variable via a Class Module.

You will need
1) Class module named cScreen
2) A std module
3) An entry in the Thisworkbook object

Here they are;

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.Run ("Restore_Scrn")
End Sub

Private Sub Workbook_Open()
Application.Run ("Set_Scrn")
End Sub



'2)

Option Explicit
'// Keep Old settings here
'=========================
Public dIniScrnW As Double
Public dIniScrnH As Double
Public nDC****** As Long
'=========================

'//>> Added Const to handle Update
Private Const WM_DISPLAYCHANGE = &H7E
Private Const HWND_BROADCAST = &HFFFF&
Private Const BITSPIXEL = 12

'//>>
Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000
Private Const CDS_UPDATEREGISTRY = &H1
Private Const CCDEVICENAME = 32
Private Const CDS_TEST = &H4
Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DISP_CHANGE_RESTART = 1
Private Const CCFORMNAME = 32

Private Type typDevMODE
****dmDeviceName****** As String * CCDEVICENAME
****dmSpecVersion******As Integer
****dmDriverVersion****As Integer
****dmSize************ As Integer
****dmDriverExtra******As Integer
****dmFields********** As Long
****dmOrientation******As Integer
****dmPaperSize********As Integer
****dmPaperLength******As Integer
****dmPaperWidth****** As Integer
****dmScale************As Integer
****dmCopies********** As Integer
****dmDefaultSource****As Integer
****dmPrintQuality**** As Integer
****dmColor************As Integer
****dmDuplex********** As Integer
****dmYResolution******As Integer
****dmTTOption******** As Integer
****dmCollate**********As Integer
****dmFormName******** As String * CCFORMNAME
****dmUnusedPadding****As Integer
****dmBitsPerPel****** As Integer
****dmPelsWidth********As Long
****dmPelsHeight****** As Long
****dmDisplayFlags**** As Long
****dmDisplayFrequency As Long
End Type

Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _
****(ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lptypDevMode As Any) As Boolean



Private Declare Function ChangeDisplaySettings Lib "user32" Alias _
****"ChangeDisplaySettingsA" (lptypDevMode As Any, ByVal dwFlags As Long) As Long

Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, _
** ByVal dwReserved As Long) As Long


'// >>Added these API to fix screen update

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
****(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Sub ChangeScreen_Resol(dScrnW As Double, dScrnH As Double)
Dim typDevM As typDevMODE
Dim lResult As Long
Dim iAns As Integer

'// Retrieve info about the current graphics mode
'// on the current display device.
'// Note: Declared All Types
'// other wise the Excel will crash
lResult = EnumDisplaySettings(0, 0, typDevM)

'// Set the new resolution.
With typDevM
****.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
****.dmPelsWidth = dScrnW**'=800**'ScreenWidth**(640,800,1024, etc)
****.dmPelsHeight = dScrnH '=600**'ScreenHeight (480,600,768, etc)
End With

'// Change the display settings to the specified graphics mode.
lResult = ChangeDisplaySettings(typDevM, CDS_TEST)
Select Case lResult
****Case DISP_CHANGE_RESTART
********iAns = MsgBox("You must restart your computer To apply these changes." & _
************vbCrLf & vbCrLf & "Do you want To restart now?", _
************vbYesNo + vbSystemModal, "Screen Resolution")
********If iAns = vbYes Then Call ExitWindowsEx(EWX_REBOOT, 0)
****Case DISP_CHANGE_SUCCESSFUL
********Call ChangeDisplaySettings(typDevM, CDS_UPDATEREGISTRY)
********'//>> Fixed screen taskbar here! thanks to API net
********'//>> Notify all the windows of the screen resolution change
********Dim lScInfo As Long, lBits As Long
********lScInfo = dScrnW * 2 ^ 16 + dScrnH
********nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
********lBits = GetDeviceCaps(nDC, BITSPIXEL)
********SendMessage HWND_BROADCAST, WM_DISPLAYCHANGE, ByVal lBits, ByVal lScInfo
****Case Else
********MsgBox "An error occured trying to set the display!"
End Select


End Sub



Sub ClrD()
'delete our device context
DeleteDC nDC
End Sub

'1)

Option Explicit
' // The GetSystemMetrics function retrieves various system metrics
' // and system configuration settings. System metrics are the dimensions
' // (widths and heights) of Windows display elements.
' // All dimensions retrieved by GetSystemMetrics are in pixels.
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Dim oScrn As cScreen 'Reference the New Class


Private Sub Set_Scrn()
'// Note: On some systems the Taskbar may need to be Reset/Repositioned
'// do this manually by selecting and moving to the side and then
'// moving back.
'// Will look into a fix for this
'// Fixed this Thanks to API net
'// See >>



On Error GoTo Ex
'// Create a New instance of Class to reference
Set oScrn = New cScreen
With oScrn
****.dIniScrnH = GetSystemMetrics(SM_CYSCREEN) '600
****.dIniScrnW = GetSystemMetrics(SM_CXSCREEN) '800
****If .dIniScrnH <> 600 Or .dIniScrnW <> 800 Then
********Call .ChangeScreen_Resol(800, 600)
****End If
End With

Ex:
Application.WindowState = xlMaximized

End Sub



Private Sub Restore_Scrn()
' //
' // Always restore back to the users
' // Original Screen settings !
' //
' // Incase of Error leave everything Alone
On Error Resume Next
Call oScrn.ChangeScreen_Resol(oScrn.dIniScrnW, oScrn.dIniScrnH)
'delete our device context
Call oScrn.ClrD
Application.WindowState = xlMaximized
On Error GoTo 0
End Sub


If this is not clear then I can send workbook

[Jimmmy]

Ivan,

Do you still have this workbook? I seem to be having the same problem everytime I click on a link that opens an excel workbook and generates a graph using macros.