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 CDS_UPDATEREGISTRY = &H1
Const CDS_TEST = &H4
Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
Const BITSPIXEL = 12
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 EnumDisplaySettings
Lib "user32"
Alias "EnumDisplaySettingsA" (
ByVal lpszDeviceName
As Long,
ByVal iModeNum
As Long, lpDevMode
As Any)
As Boolean
Private Declare Function ChangeDisplaySettings
Lib "user32"
Alias "ChangeDisplaySettingsA" (lpDevMode
As Any,
ByVal dwFlags
As Long)
As Long
Private Declare Function ExitWindowsEx
Lib "user32" (
ByVal uFlags
As Long,
ByVal dwReserved
As Long)
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
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
Dim 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
 
evM.dmFields = DM_PELSWIDTH
Or DM_PELSHEIGHT
Or DM_BITSPERPEL
 
evM.dmPelsWidth = X
'ScreenWidth
 
evM.dmPelsHeight = Y
'ScreenHeight
 
evM.dmBitsPerPel = Bits
'(can be 8, 16, 24, 32 or even 4)
'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
Private Sub Form_Load()
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
Dim nDC
As Long
'retrieve the screen's resolution
OldX = Screen.Width / Screen.TwipsPerPixelX
OldY = Screen.Height / Screen.TwipsPerPixelY
'Create a device context, compatible with the screen
nDC = CreateDC("
ISPLAY", vbNullString, vbNullString,
ByVal 0&
'Change the screen's resolution
ChangeRes 640, 480, GetDeviceCaps(nDC, BITSPIXEL)
End Sub
Private Sub Form_Unload(Cancel
As Integer)
'restore the screen resolution
ChangeRes OldX, OldY, GetDeviceCaps(nDC, BITSPIXEL)
'delete our device context
 
eleteDC nDC
End Sub