Ка изменить разрешение экрана , Screen resolution \ Display frequency

[Vasya2000]

tnx for XPraptor
вариант1

'Декларируем API функции
Public Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long
Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
 
'Объявляем глобальные константы и типы
Public Const DRIVERVERSION = 0      '  Device driver version
Public Const TECHNOLOGY = 2         '  Device classification
Public Const HORZSIZE = 4           '  Horizontal size in millimeters
Public Const VERTSIZE = 6           '  Vertical size in millimeters
Public Const HORZRES = 8            '  Horizontal width in pixels
Public Const VERTRES = 10           '  Vertical width in pixels
Public Const BITSPIXEL = 12         '  Number of bits per pixel
Public Const PLANES = 14            '  Number of planes
Public Const NUMBRUSHES = 16        '  Number of brushes the device has
Public Const NUMPENS = 18           '  Number of pens the device has
Public Const NUMMARKERS = 20        '  Number of markers the device has
Public Const NUMFONTS = 22          '  Number of fonts the device has
Public Const NUMCOLORS = 24         '  Number of colors the device supports
Public Const PDEVICESIZE = 26       '  Size required for device descriptor
Public Const CURVECAPS = 28         '  Curve capabilities
Public Const LINECAPS = 30          '  Line capabilities
Public Const POLYGONALCAPS = 32     '  Polygonal capabilities
Public Const TEXTCAPS = 34          '  Text capabilities
Public Const CLIPCAPS = 36          '  Clipping capabilities
Public Const RASTERCAPS = 38        '  Bitblt capabilities
Public Const ASPECTX = 40           '  Length of the X leg
Public Const ASPECTY = 42           '  Length of the Y leg
Public Const ASPECTXY = 44          '  Length of the hypotenuse
 
Public Const LOGPIXELSX = 88        '  Logical pixels/inch in X
Public Const LOGPIXELSY = 90        '  Logical pixels/inch in Y
 
Public Const SIZEPALETTE = 104      '  Number of entries in physical palette
Public Const NUMRESERVED = 106      '  Number of reserved entries in palette
Public Const COLORRES = 108         '  Actual color resolution
 
 
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CCFORMNAME = 32
Public Const CCDEVICENAME = 32
 
Public 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
 
'Получает текущее разрешение экрана
Public Sub GetVideoMode(ByRef Width As Long, ByRef height As Long, ByRef Depth As Long)
Dim hDC As Long 'Контекст устройства
  On Error GoTo errDebug
 
  hDC = GetDC(GetDesktopWindow()) 'Получаем контекст учтройства (Desktop)
  Width = GetDeviceCaps(hDC, HORZRES) 'Получаем ширину экрана в пикселях
  height = GetDeviceCaps(hDC, VERTRES) 'Получаем высоту экрана в пикселях
  Depth = GetDeviceCaps(hDC, BITSPIXEL) 'Получаем глубину цвета (4=16ц, 8=256ц, 12=16H ц, 16=32H ц)
  ReleaseDC GetDesktopWindow(), hDC 'Освобождаем устройство
    Exit Sub
errDebug:
    'Обрабатываем возникшие ошибки
End Sub
 
'Изменяет Текущее разрешение Экрана
Public Sub ChangeResolution(ByRef iWidth As Long, ByRef iHeigh As Long, ByRef iDepth As Integer, ByRef iFreq As Long, Auto As Boolean)
Dim DevM As DEVMODE
Dim a As Boolean
Dim i As Long
Dim b As Long
 
Dim freqs& 'Частота регенерации
Dim Wd& 'Ширина pxl
Dim Hg& 'Высота pxl
Dim Dept% 'Глубина цвета
 
Dim mxfreqs&
Dim mxWd&
Dim mxHg&
Dim mxDept%
Dim DevName$
 
i = 0
mxfreqs& = 0
mxWd& = 0
mxHg& = 0
mxDept% = 0
Do While i < 10000
    a = EnumDisplaySettings(0&, i&, DevM) 'Проходим по всему списку поддерживаемых параметров монитора
    If a <> False Then
    If Auto = True Then 'Если = True, то программа сама попытается выставить максимально возможные параметры для данного монитора
        freqs = DevM.dmDisplayFrequency
        Wd = DevM.dmPelsWidth
        Hg = DevM.dmPelsHeight
        Dept = DevM.dmBitsPerPel
        If freqs >= mxfreqs And Wd = iWidth And Hg = iHeigh And Dept >= mxDept Then
            mxfreqs = freqs
            If Wd = iWidth Then mxWd& = Wd&
            If Hg = iHeigh Then mxHg& = Hg&
            mxDept% = Dept%
        End If
    End If
    Else
        Exit Do
    End If
    i = i + 1
Loop
If Auto = True Then
    DevM.dmPelsWidth = mxWd
    DevM.dmPelsHeight = mxHg
    DevM.dmBitsPerPel = mxDept
        If mxfreqs > 110 Then 'Если максимальная частота регенерации высокая, значит в установках монитора не стоит check "Скрывать частоту не поддерживаемую монитором и программа выставляет 60Hz"
            DevM.dmDisplayFrequency = 60
        Else
            DevM.dmDisplayFrequency = mxfreqs
        End If
Else 'Если Auto=False, то монитору устанавливаются параметры указанные при вызове процедуры
    DevM.dmPelsWidth = iWidth
    DevM.dmPelsHeight = iHeigh
    DevM.dmBitsPerPel = iDepth
    DevM.dmDisplayFrequency = iFreq
End If
b = ChangeDisplaySettings(DevM, 1) 'Применяются новые параметры
'''''''''''
'здесь можно разместить код включения таймера, если параметры не поддерживаются монитором
''''''''''
End Sub
 
 
'Вызываются следующим образом:
'Sub DetectScreen ()
'Dim Wd As Long
'Dim Hg As Long
'Dim Dpt As Long
'   GetVideoMode Wd, Hg, Dpt
' Теперь Wd, Hg и Dpt равны параметрам экрана
'Для изменеия вызываем:
'Call ChangeResolution(1024, 768, 16, 100, False)
'или
'Call ChangeResolution(0, 0, 0, 0, True)'Для автоматического определения
'End Sub
 
'Желаю успехов в нелегком деле программирования (XPraptor)

tnx for Ruben
вариант2

'//ЧТОБЫ ЭТОТ ПРОЕКТ РАБОТАЛ ПОНАДОБИТСЯ DIRECTX7
'//ЗАЙДИ В PROJECT>REFERENCES И ДОБАВЬ "DirectX 7 for Visual Basic Type Library"
 
Dim dx7 As New DirectX7
Dim dd As DirectDraw7
 
Private Sub Form_Load()
   Init
End Sub
 
Sub Init()
 
   Set dd = dx7.DirectDrawCreate("")
 
   '//FULL SCREEN MOD
   Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or     DDSCL_EXCLUSIVE)
   Call dd.SetDisplayMode(800, 600, 32, 0, DDSDM_DEFAULT) '//DispWidth, DispHeight, Bits
 
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
   Call dd.RestoreDisplayMode
   Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
End Sub

tnx for Slip
Вариант 3

Option Explicit
Const WM_DISPLAYCHANGE = &H7E
Const HWND_BROADCAST = &HFFFF&
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_BITSPERPEL = &H40000
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_DISPLAYFREQUENCY = &H400000
Const CDS_UPDATEREGISTRY = &H1
Const CDS_TEST = &H4
Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
Const BITSPIXEL = 12
Public 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
Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Public Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public 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
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public OldX As Long, OldY As Long, nDC As Long
 
Sub ChangeRes(X As Long, Y As Long, Bits As Long)
    Dim DevM As DEVMODE, ScInfo As Long, erg As Long, an As VbMsgBoxResult
    'Get the info into DevM
    erg = EnumDisplaySettings(0&, 0&, DevM)
    'This is what we're going to change
    DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL Or DM_DISPLAYFREQUENCY
    DevM.dmPelsWidth = 800 'ScreenWidth
    DevM.dmPelsHeight = 600 'ScreenHeight
    DevM.dmBitsPerPel = 32 '(can be 8, 16, 24, 32 or even 4)
    DevM.dmDisplayFrequency = 85
    'Now change the display and check if possible
    erg = ChangeDisplaySettings(DevM, CDS_TEST)
    'Check if succesfull
    Select Case erg&
        Case DISP_CHANGE_RESTART
            an = MsgBox("You've to reboot", vbYesNo + vbSystemModal, "Info")
            If an = vbYes Then
                erg& = ExitWindowsEx(EWX_REBOOT, 0&)
            End If
        Case DISP_CHANGE_SUCCESSFUL
            erg = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
            ScInfo = Y * 2 ^ 16 + X
            'Notify all the windows of the screen resolution change
            SendMessage HWND_BROADCAST, WM_DISPLAYCHANGE, ByVal Bits, ByVal ScInfo
            MsgBox "Everything's ok", vbOKOnly + vbSystemModal, "It worked!"
        Case Else
            MsgBox "Mode not supported", vbOKOnly + vbSystemModal, "Error"
    End Select
End Sub

Сообщение отредактировано: Vasya2000 - 16.04.04, 04:18

[Vasya2000]

Цитата

SCINER
Вот все исходники:
Суть: перебор 5 методов в лоб.
Хоть один да сработает.

Прикреплённый файлresolutor.zip (16.54 Кбайт, скачиваний: 218)