Display Current Screen Resolution on form or Message Box 5

[MwTV]

I am interested in displaying a message box or a form that the end user sees upon entering the database with something similar to the following;

"Ideally, this database should have a screen resolution of 1024 x 800. Your screen resolution is currently set up as 800 x 600."

Any idea as to how this can be accomplished?

Thank you.

 

[ZmrAbdulla]

Here is one

http://www.issociate.de/board/post/240967/Is_there_a_way_to_change_screen_resolution_in_VBA.html

________________________________________________________
Zameer Abdulla
Help to find Missing people
Take the first step in faith. You don't have to see the whole staircase, just take the first step.
(Dr. Martin Luther King Jr.)

 

[ZmrAbdulla]

and one more

http://www.bygsoftware.com/Excel/VBA/screen_size.htm

________________________________________________________
Zameer Abdulla
Help to find Missing people
Take the first step in faith. You don't have to see the whole staircase, just take the first step.
(Dr. Martin Luther King Jr.)

 

[TheAceMan1]

How are ya MwTV . . .

Here an API that works well . . .

[blue]Private Declare Function apiGetSys Lib "user32" _
    Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CXVSCROLL = 2
Private Const SM_CYHSCROLL = 3
Private Const SM_CYCAPTION = 4
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6
Private Const SM_CXDLGFRAME = 7
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYVTHUMB = 9
Private Const SM_CXHTHUMB = 10
Private Const SM_CXICON = 11
Private Const SM_CYICON = 12
Private Const SM_CXCURSOR = 13
Private Const SM_CYCURSOR = 14
Private Const SM_CYMENU = 15
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CYFULLSCREEN = 17
Private Const SM_CYKANJIWINDOW = 18
Private Const SM_MOUSEPRESENT = 19
Private Const SM_CYVSCROLL = 20
Private Const SM_CXHSCROLL = 21
Private Const SM_DEBUG = 22
Private Const SM_SWAPBUTTON = 23
Private Const SM_RESERVED1 = 24
Private Const SM_RESERVED2 = 25
Private Const SM_RESERVED3 = 26
Private Const SM_RESERVED4 = 27
Private Const SM_CXMIN = 28
Private Const SM_CYMIN = 29
Private Const SM_CXSIZE = 30
Private Const SM_CYSIZE = 31
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33
Private Const SM_CXMINTRACK = 34
Private Const SM_CYMINTRACK = 35
Private Const SM_CXDOUBLECLK = 36
Private Const SM_CYDOUBLECLK = 37
Private Const SM_CXICONSPACING = 38
Private Const SM_CYICONSPACING = 39
Private Const SM_MENUDROPALIGNMENT = 40
Private Const SM_PENWINDOWS = 41
Private Const SM_DBCSENABLED = 42
Private Const SM_CMOUSEBUTTONS = 43
Private Const SM_CMETRICS = 44

Function fGetSysStuff(strWhat As String) As String
Dim strRet As String
    Select Case LCase(strWhat)
        Case "resolution": strRet = apiGetSys(SM_CXSCREEN) & "x" _
                                        & apiGetSys(SM_CYSCREEN)
        Case "windowsize": strRet = apiGetSys(SM_CXFULLSCREEN) & "x" _
                                        & apiGetSys(SM_CYFULLSCREEN)
    End Select
    fGetSysStuff = strRet
End Function[/blue]

See Ya! . . . . . .

 

[MwTV]

Thanks for the insight,

Still trying to specifically determine how I would display the following pop up form or message box with "Ideally, this database should have a screen resolution of 1024 x 800. Your screen resolution is currently set up as 800 x 600." using the information given?

My understanding is that the code can go in the "On click" event of the command button that is on the welcome page of the multi-tabbed form. Then, the pop-up form or message box should appear.

Forgive me for not grasping all of the information but how would I implement?

 

[TheAceMan1]

ZmrAbdulla ? . . .

See Ya! . . . . . .

 

[ZmrAbdulla]

Paste the code (of second link I provided) to a new module.

Insert a command button on the form and name it like "cmdGetResolution"

OnClick event of the command button you can have this code.

Private Sub cmdGetResolution_Click()
    Dim strScrRes As String
    strScrRes = GetScreenResolution
    If strScrRes <> "1024x800" Then
        MsgBox "Ideally, this database should have a screen" & _
                "resolution of 1024 x 800" & vbCrLf & _
                "Your screen resolution is currently set up as " & strScrRes & vbCrLf & _
                "Please change it to 1024 x 800", vbOKOnly + vbExclamation, "Screen Resolution"
    End If
End Sub

Try replacing the code to different events like form's OnLoad or OnOpen ..



________________________________________________________
Zameer Abdulla
Help to find Missing people
Take the first step in faith. You don't have to see the whole staircase, just take the first step.
(Dr. Martin Luther King Jr.)

 

[MwTV]

Thanks Zameer,

I modified the code in the onclick event of the command button to display the first line as "Ideally, this database should have a minimum screen resolution of 1024 x 800"

Now, my thought is that several if statements are needed to test if the minimum screen resolution is on the end-users' computer.

My first iteration at this concept is below;

1st Iteration

Private Sub cmdGetResolution_Click()
Dim strScrRes As String
strScrRes = GetScreenResolution
If strScrRes = "800x600" Then
MsgBox "Ideally, this database should have a minimum screen" & _
"resolution of 1024 x 800" & vbCrLf & _
"Your screen resolution is currently set up as " & strScrRes & vbCrLf & _
"Please change it to 1024 x 800", vbOKOnly + vbExclamation, "Screen Resolution"
End If

If strScrRes = "900x200" Then 'Sample
MsgBox "Ideally, this database should have a minimum screen" & _
"resolution of 1024 x 800" & vbCrLf & _
"Your screen resolution is currently set up as " & strScrRes & vbCrLf & _
"Please change it to 1024 x 800", vbOKOnly + vbExclamation, "Screen Resolution"
End If

If strScrRes = "1024x800" Then 'Sample
MsgBox "Ideally, this database should have a minimum screen" & _
"resolution of 1024 x 800" & vbCrLf & _
"Your screen resolution is currently set up as " & strScrRes & vbCrLf & _
"You do not need to adjust your screen resolution"
End If
End Sub

Am I on the right path or is this concept feasible? How would you do differently?

Thanks in advance.

 

[TheAceMan1]

MwTV . . .

[blue]Private Sub cmdGetResolution_Click()
   Dim strScrRes As String
   Dim Msg As String, Style As Integer, Title As String, DL As String
   
   DL = vbNewLine & vbNewLine
   strScrRes = GetScreenResolution
   Style = vbInformation + vbOKOnly
    
   If strScrRes = "800x600" Or strScrRes = "900x200" Then
      Msg = "Ideally, this database should have a minimum screen" & _
            "resolution of 1024 x 800" & DL & _
            "Your screen resolution is currently set up as " & _
             strScrRes & DL & _
            "Please change it to 1024 x 800"
      Title = "Improper Screen Resolution Detected! . . ."
      MsgBox Msg, Style, Title
   ElseIf strScrRes = "1024x800" Then   'Sample
      Msg = "Ideally, this database should have a minimum screen" & _
            "resolution of 1024 x 800" & DL & _
            "Your screen resolution is currently set up as " & _
             strScrRes & DL & _
            "You do not need to adjust your screen resolution"
      Title = "Proper Screen Resolution Detected! . . ."
      MsgBox Msg, Style, Title
   End If

End Sub[/blue]

See Ya! . . . . . .

 

[MwTV]

Thanks AceMan1,

I will try this and post back.

 

[AccessGuruCarl]

The AceMan1,
Nice piece of code, But it failed on my display adapter. Every video card is 'slightly' different and you would need to test for alot of different variables.

MwTV,

Try this one... It detects all available, and gives user option to change resolution while working in db, then resets it back when they close it.

Startup form or a hidden form that loads at startup

Private Sub Form_Load()
DoCmd.Restore
    fGetCurrentRes
End Sub
'
Private Sub Form_Unload(Cancel As Integer)
    SetOrigRes
End Sub

Paste this code into a new module

Option Compare Database
Option Explicit

'Thanks to KPD-Team
'For the API and variables in this module
'Visit them at [URL unfurl="true"]http://www.allapi.net/[/URL]
'Note:
'Form should be maximised so that it fills the whole screen
'when loaded
'===========================================================
'Note:
'Color quality and screen resolution can only be changed
'if it is supported by the Graphics Card\Operating System.
'===========================================================
'Common Screen Resoulutions:
'==============='
'Width   Height '
'==============='
'640     480    '
'800     600    '
'1024    768    '
'1280    1024   '
'1600    1200   '
'==============='
'
'Common Color Qualities:
'==============================================================='
'Bits   # colors        Common Name
'==============================================================='
'4      16              16 Colors                               '
'8      256             256 Colors                              '
'16     65,536          High Color (16-Bit)                     '
'24     16,777,216      True Color (24-bit)                     '
'32     4,294,967,296   True Color (32-Bit/24bit + 8bit Alpha)  '
'==============================================================='


Const ENUM_CURRENT_SETTINGS As Long = -1&    'Get current settings
Const DM_PELSWIDTH = &H80000        'Pixels in width
Const DM_PELSHEIGHT = &H100000      'Pixels in height
Const DM_BITSPERPEL = &H40000       'Color Depth
Const DM_DISPFREQ = &H400000        'Display Frequency
Const CDS_TEST = &H4
Private Type DEVMODE
    dmDeviceName As String * 32 'Name of graphics card?????
    dmSpecVersion As Integer
    dmDriverVersion As Integer 'graphics card driver version?????
    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 * 32 'Name of form?????
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer 'Color Quality (can be 8, 16, 24, 32 or even 4)
    dmPelsWidth As Long 'Display Width in pixels
    dmPelsHeight As Long 'Display height in pixels
    dmDisplayFlags As Long
    dmDisplayFrequency As Long 'Display frequency
    dmICMMethod As Long 'NT 4.0
    dmICMIntent As Long 'NT 4.0
    dmMediaType As Long 'NT 4.0
    dmDitherType As Long 'NT 4.0
    dmReserved1 As Long 'NT 4.0
    dmReserved2 As Long 'NT 4.0
    dmPanningWidth As Long 'Win2000
    dmPanningHeight As Long 'Win2000
End Type

Private Declare Function ChangeDisplaySettingsEx Lib "user32" Alias "ChangeDisplaySettingsExA" (lpszDeviceName As Any, lpDevMode As Any, ByVal hWnd As Long, ByVal dwFlags As Long, lParam As Any) As Long
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean

Dim DevM As DEVMODE
Dim OldX As Integer, OldY As Integer, OldColor As Integer, OldFreq As Integer
Dim SetX As Integer, SetY As Integer, SetColor As Integer, SetFreq As Integer
Public Function fGetCurrentRes()
    '=======================================================
    'Call this sub in Form_Load
    '=======================================================
    Dim ScreenResolutionCheck As Integer
    Dim intResponse As Integer
    ScreenResolutionCheck = 0
    'Save original (current) resolution
    EnumDisplaySettings 0&, ENUM_CURRENT_SETTINGS, DevM     'Get current setting
    OldX = DevM.dmPelsWidth     'or OldX = Screen.Width / Screen.TwipsPerPixelX
    OldY = DevM.dmPelsHeight    'or OldY = Screen.Height / Screen.TwipsPerPixelY
    OldColor = DevM.dmBitsPerPel
    OldFreq = DevM.dmDisplayFrequency
    'Apply new resolution
    fGetCurrentRes = OldX & " x " & OldY
    
    If (OldX) < 1020 Or (OldX) > 1024 Then
        ScreenResolutionCheck = _
        MsgBox(" Your Screen Resolution is set to " & _
                OldX & " x " & OldY & _
                Chr(13) & Chr(13) & _
                "    THIS DATABASE IS BEST VIEWED WITH" & _
                Chr(10) & Chr(13) & _
                "   SCREEN RESOLUTION SET TO 1024 x 768" & _
                Chr(10) & Chr(13) & Chr(10) & Chr(13) & _
                "Would you like to change display setting" & _
                Chr(10) & Chr(13) & _
                " while working in database?", vbYesNo, _
                "SCREEN RESOLUTION RECOMMENDATION")
                
    End If
    
    Select Case ScreenResolutionCheck
        Case 6  'Yes
            ChangeRes 1024, 768, 0, 0
        Case Else  ' No is selected
            'Do nothing
    End Select
    
End Function

Public Sub GetCurrentRes()
    '=======================================================
    'Call this sub in Form_Load
    '=======================================================
' Orginal Code here - See modified function above
    'Save original (current) resolution
    EnumDisplaySettings 0&, ENUM_CURRENT_SETTINGS, DevM     'Get current setting
    OldX = DevM.dmPelsWidth     'or OldX = Screen.Width / Screen.TwipsPerPixelX
    OldY = DevM.dmPelsHeight    'or OldY = Screen.Height / Screen.TwipsPerPixelY
    OldColor = DevM.dmBitsPerPel
    OldFreq = DevM.dmDisplayFrequency
    'Apply new resolution
    ChangeRes 800, 600, 16, 60
End Sub

Public Sub SetOrigRes()
    '=======================================================
    'Call this sub in Form_Unload
    '=======================================================
    
    'Change the display settings back to the old settings
    ChangeRes OldX, OldY, OldColor, OldFreq
End Sub

Public Sub ChangeRes(ScreenX As Integer, ScreenY As Integer, ScreenColor As Integer, ScreenFreq As Integer)
    '=======================================================
    'ChangeRes sub format (can be set at runtime):
    'Insert a zero if you don't want to change an aspect
    'eg:
    'ChangeRes 800, 600, 16, 60     '800x600 pixels, 16 bit Color, 60Hz
    'ChangeRes 800, 600, 16, 0      '800x600 pixels, 16 bit Color
    'ChangeRes 800, 600, 0, 60      '800x600 pixels, 60Hz
    'ChangeRes 0, 0, 16, 60         '16 bit Color, 60Hz
    'ChangeRes 0, 0, 16, 0          '16 bit Color
    'ChangeRes 800, 600, 0, 0       '800x600 pixels
    'ChangeRes 0, 0, 0, 60          '60Hz
    '=======================================================
    
    '=======================================================
    'The "EndIf" statement is used because if a "0" is used
    'in the API call, the API considers it as an aspect that
    'does not need to be changed, but is the current system
    'setting.
    'eg:
    'ChangeRes 0, 0, 0, 0   =   The current system setting
    'ChangeRes 0, 0, 16, 0  =   The current resolution and display frequency setting, with new color quality
    '=======================================================
    
    'Get selected resolution
    If ScreenX <> 0 And ScreenY <> 0 And ScreenColor = 0 And ScreenFreq = 0 Then
        DevM.dmPelsWidth = ScreenX          'Screen width
        DevM.dmPelsHeight = ScreenY         'Screen height
        DevM.dmBitsPerPel = SetColor        'Screen color quality
        DevM.dmDisplayFrequency = SetFreq   'Screen display frequency
        'SetX = ScreenX
        'SetY = ScreenY
        SaveIt ScreenX, ScreenY, ScreenColor, ScreenFreq, "ChangeResol"
        'DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
    ElseIf ScreenX = 0 And ScreenY = 0 And ScreenColor <> 0 And ScreenFreq = 0 Then
        DevM.dmPelsWidth = SetX             'Screen width
        DevM.dmPelsHeight = SetY            'Screen height
        DevM.dmBitsPerPel = ScreenColor     'Screen color quality
        DevM.dmDisplayFrequency = SetFreq   'Screen display frequency
        'SetColor = ScreenColor
        SaveIt ScreenX, ScreenY, ScreenColor, ScreenFreq, "ChangeColor"
        'DevM.dmFields = DM_BITSPERPEL
    ElseIf ScreenX = 0 And ScreenY = 0 And ScreenColor = 0 And ScreenFreq <> 0 Then
        DevM.dmPelsWidth = SetX                 'Screen width
        DevM.dmPelsHeight = SetY                'Screen height
        DevM.dmBitsPerPel = SetColor            'Screen color quality
        DevM.dmDisplayFrequency = ScreenFreq    'Screen display frequency
        'SetFreq = ScreenFreq
        SaveIt ScreenX, ScreenY, ScreenColor, ScreenFreq, "ChangeFreq"
        'DevM.dmFields = DM_DISPFREQ
    ElseIf ScreenX <> 0 And ScreenY <> 0 And ScreenColor <> 0 And ScreenFreq <> 0 Then
        DevM.dmPelsWidth = ScreenX             'Screen width
        DevM.dmPelsHeight = ScreenY            'Screen height
        DevM.dmBitsPerPel = ScreenColor        'Screen color quality
        DevM.dmDisplayFrequency = ScreenFreq   'Screen display frequency
        SaveIt ScreenX, ScreenY, ScreenColor, ScreenFreq, "ChangeAll"
        'DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL Or DM_DISPFREQ
    ElseIf ScreenX = 0 And ScreenY = 0 And ScreenColor = 0 And ScreenFreq = 0 Then
        Exit Sub
    End If
    'we want to change the horizontal and the vertical
    'resolution, the color quality, and the display
    'frequency (screen refresh rate)
    DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL Or DM_DISPFREQ
    
    'change the display settings
    Call ChangeDisplaySettingsEx(ByVal 0&, DevM, ByVal 0&, CDS_TEST, ByVal 0&)
End Sub

Private Sub SaveIt(ScX As Integer, ScY As Integer, ScC As Integer, ScF As Integer, ScreenChanged As String)
    Select Case ScreenChanged
        Case "ChangeResol"
            SetX = ScX      'Screen width
            SetY = ScY      'Screen height
        Case "ChangeColor"
            SetColor = ScC  'Screen color quality
        Case "ChangeFreq"
            SetFreq = ScF   'Screen display frequency
        Case "ChangeAll"
            SetX = ScX      'Screen width
            SetY = ScY      'Screen height
            SetColor = ScC  'Screen color quality
            SetFreq = ScF   'Screen display frequency
    End Select
End Sub

You modify your screen setting in Public Function fGetCurrentRes()

I use this in all my db's, and haven't had any complaints so far.

This file came from Planet-Source-Code.com
You can download a sample mdb, view comments on this code/and or vote on it at:

http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=52479&lngWId=1

Hope this helps



AccessGuruCarl
Programmers helping programmers
you can't find a better site.

 

[MwTV]

AccessGuruCarl,

Thanks.

Will post back the results.

 

[AccessGuruCarl]

Forgot to add this....

If you really want to get all the available resolutions:

Add this at the beginning of the module right after the last Dim statement and before the 1st function:

Global arrDisplay() As String
Global arrI As Integer

Function fEnumDisplay() As Collection
Dim collRes As Collection
Dim boolRet As Boolean
Dim tDevMode As DEVMODE
Dim lngMode As Long
arrI = 0
ReDim arrDisplay(arrI)
    Set collRes = New Collection
    Do
        boolRet = EnumDisplaySettings(0&, lngMode&, tDevMode)
        With tDevMode
            collRes.Add .dmPelsWidth & "x" & _
                    .dmPelsHeight & " @ " & .dmBitsPerPel & " bit", _
                    lngMode & vbNullString
                    
            arrDisplay(arrI) = .dmPelsWidth & "x" & .dmPelsHeight & " @ " & .dmBitsPerPel & " bit" & " Mode= " & lngMode
            arrI = arrI + 1
            ReDim Preserve arrDisplay(arrI)
        End With
        lngMode = lngMode + 1
    Loop Until boolRet = False
    Set fEnumDisplay = collRes
    Set collRes = Nothing
End Function

Now add a button on a form and insert this code:

Dim i As Integer
    Call fEnumDisplay
    For i = 0 To (arrI - 1)
        Debug.Print arrDisplay(i)
    Next i
    MsgBox "Finished - View Immediate window to view settings."

Open the code window after pressing the button:
and press Ctl G to view the Immediate Window...
It will display all the resolutions and color settings available.

As you can see, There is alot of them.... And different video adapters will produce a different output...

But the code is nice for testing..... purposes...

AccessGuruCarl
Programmers helping programmers
you can't find a better site.

 

[AccessGuruCarl]

I suppose if you really want to give the user a choice:

When it's looping the Function fEnumDisplay() where it get's to the array, you can check if it's an acceptable size then add it to the array. When's it finished if the default size is not set display a form instead of the message box.

Something like this:
ScreenWidth > 900 and ColorMode > 8
If .dmPelsWidth > 900 AND .dmBitsPerPel > 8 Then
arrDisplay(arrI) = .dmPelsWidth & "x" & .dmPelsHeight & " @ " & .dmBitsPerPel & " bit"
arrI = arrI + 1
ReDim Preserve arrDisplay(arrI)
End If

** Quick NOTE:
Not really sure what Mode is, it's not the Freq...You'll see I removed it from the array. And you really shouldn't play around with the screen display frequency, I've read in other post's that if you set it to a Freq not supported you could damage the video card. Your user's wont be very happy!

ALWAYS CHANGE ONLY THE FIRST 3 VALUES IF NEEDED: See comments in the Public Sub ChangeRes about 0 numbers!

On the form, add a combobox, and set it's source to the array. On the AfterUpdate event of the combobox, parse out the values, and call the public Sub ChangeRes.

Have Fun....

AccessGuruCarl
Programmers helping programmers
you can't find a better site.

 

[TheAceMan1]

howdy AccessGuruCarl . . .

Wow! . . . I was just showing [blue]MwTV[/blue] how to write their code better and in fewer lines! . . .

See Ya! . . . . . .

 

[PHV]

Another way to get screen resolution, without API:
Dim objWMI As Object, colItems, objItem
Set objWMI = GetObject("winmgmts:\\.\root\CIMV2")
Set colItems = objWMI.ExecQuery("SELECT * FROM Win32_DisplayConfiguration", "WQL", &H30)
For Each objItem In colItems
MsgBox "ScreenRes is " & objItem.PelsHeight & "x" & objItem.PelsWidth
Next

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[AccessGuruCarl]

Hello TheAceMan1,

Sorry, If I offended you...
Was just offering another solution, that I know has worked in the past for all occasions..

PHV - Now that's a short piece of code!

Both PHV and yourself have given me great tips in the past, keep it up! Didn't mean to step on any toes... LOL

Have a nice day




AccessGuruCarl
Programmers helping programmers
you can't find a better site.

 

[TheAceMan1]

[blue]Sorry, If I offended you... [/blue]

Noooooo . . . not at all! . . . Nick come back!

See Ya! . . . . . .

 

[ZmrAbdulla]

Wow.. Thanks to all.. Nice follow up..

I was away for two days.

________________________________________________________
Zameer Abdulla
Help to find Missing people
Take the first step in faith. You don't have to see the whole staircase, just take the first step.
(Dr. Martin Luther King Jr.)

 

[georgesOne]

PHV,

do you have more such tips?
That would be really helpful... and save tons of code.

georgesOne