'Декларируем 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)

'//ЧТОБЫ ЭТОТ ПРОЕКТ РАБОТАЛ ПОНАДОБИТСЯ 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

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