Skift skærmopløsning Automatisk

Følgende kode kan gøre det:

Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000

Private Type DEVMODE
    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 apiEnumDisplaySettings Lib "user32" _
        Alias "EnumDisplaySettingsA" _
        (ByVal lpszDeviceName As Long, _
        ByVal iModeNum As Long, _
        lpDevMode As Any) _
        As Boolean

Private Declare Function apiChangeDisplaySettings Lib "user32" _
        Alias "ChangeDisplaySettingsA" _
        (lpDevMode As Any, _
        ByVal dwflags As Long) _
        As Long

Function fEnumDisplay() As Collection
Dim collRes As Collection
Dim boolRet As Boolean
Dim tDevMode As DEVMODE
Dim lngMode As Long

    Set collRes = New Collection
    Do
        boolRet = apiEnumDisplaySettings(0&, lngMode&, tDevMode)
        With tDevMode
            collRes.Add .dmPelsWidth & "x" & _
                    .dmPelsHeight & " @ " & .dmBitsPerPel & " bit", _
                    lngMode & vbNullString
        End With
        lngMode = lngMode + 1
    Loop Until boolRet = False
    Set fEnumDisplay = collRes
    Set collRes = Nothing
End Function

Function fChangeRes(intX As Integer, intY As Integer) As Boolean
Dim tDevMode As DEVMODE
Dim boolCanChange As Boolean
Dim boolRet As Boolean
Dim lngRet As Long, lngMode As Long

    On Error GoTo Err_Handler
    Do
        boolRet = apiEnumDisplaySettings(0&, lngMode&, tDevMode)
        With tDevMode
            If .dmPelsWidth = intX And .dmPelsHeight = intY Then
                boolCanChange = True
            End If
        End With
        lngMode = lngMode + 1
    Loop Until boolRet = False

    If boolCanChange Then
        With tDevMode
            .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
            .dmPelsWidth = intX
            .dmPelsHeight = intY
        End With
        lngRet = apiChangeDisplaySettings(tDevMode, 0&)
    End If
    fChangeRes = boolCanChange
exit_Handler:
    Exit Function
Err_Handler:
    fChangeRes = False
    Resume exit_Handler
End Function


Du skal blot skrive:
Call fChangeRes(1024, 768)

/Thomas
www.makeiteasy.dk

Thomas  Tak for det hyrtige svar.
Jeg har fået det til at virke den ene vej. (Når jeg åbner).
Når jeg lukker bruger jeg ved lukning:
Call fChangeRes(800, 600)
VH Henrik

Du kan også aflæse brugerens opløsning inden du skfiter til 1024*768 og derved sætte den tilbage til deres oprindelige når de lukker (hvis de i forvejen kører 1024 gider de nok ikke at få sat den ned til 800*600)

Vil du have koden til det?

Lytter med: Ja tak!

Ja tak.
VH Henrik

Alright :)
Here it is:

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


Spørg på: fGetSysStuff("resolution")
Så får I opløsningen

Spørg på: fGetSysStuff("windowsize")
Så får I Windowsstørrelse (som af ikke altid er lig opløsning)

/Thomas

Koden bør bare lægges i et selvstændigt modul.

Tak for tilsendte.
VH Henrik

anytime :o)