Option ExplicitPublic Const CCHFORMNAME = 32 Public Const CCHDEVICENAME = 32 Public Const DM_BITSPERPEL = &H40000 Public Const DM_PELSWIDTH = &H80000 Public Const DM_PELSHEIGHT = &H100000Public Const CDS_UPDATEREGISTRY = 1 Public Const CDS_TEST = 2Type DEVMODE dmDeviceName As String * CCHDEVICENAME 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 * CCHFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End TypeDeclare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long Option ExplicitDim nDisplay As Integer, devM() As DEVMODEPrivate Sub Command1_Click() devM(List1.ListIndex).dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL If ChangeDisplaySettings(devM(List1.ListIndex), CDS_TEST) = 0 Then MsgBox "测试成功!" Else MsgBox "测试失败!" End If End SubPrivate Sub Command2_Click() devM(List1.ListIndex).dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL If ChangeDisplaySettings(devM(List1.ListIndex), 0) = 0 Then MsgBox "设定成功!" Else MsgBox "设定失败!" End If End SubPrivate Sub Form_Load() Dim HasMore As Long, i As Integer
i = 0 Do ReDim Preserve devM(0 To i)
HasMore = EnumDisplaySettings(0, i, devM(i)) If HasMore = 0 Then Exit Do If devM(i).dmBitsPerPel = 24 Then List1.AddItem "全彩" & vbTab & _ devM(i).dmPelsWidth & vbTab & devM(i).dmPelsHeight Else List1.AddItem 2 ^ devM(i).dmBitsPerPel & vbTab & _ devM(i).dmPelsWidth & vbTab & devM(i).dmPelsHeight End If i = i + 1 Loop nDisplay = i End Sub 给你个例子
下面的例子将演示如何把屏幕分辨率更改为640x480(保持原来的颜色数)。 Dim DevM As DEVMODE 'DevM收集信息 erg& = EnumDisplaySettings(0&, 0&, DevM) '不改变颜色数目是因为如果改变颜色数就要重新启动 DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT 'Or DM_BITSPERPEL DevM.dmPelsWidth = 640 '屏幕宽度 DevM.dmPelsHeight = 480 '屏幕高度 'DevM.dmBitsPerPel = 32 (还可以为 8, 16, 32甚至4) 调整分辩率和取当前分辩率 改变显示模式并检查是否可能 erg& = ChangeDisplaySettings(DevM, CDS_TEST)'检查是否成功 Select Case erg& Case DISP_CHANGE_RESTART an = MsgBox("你现在必须重新启动系统,执行吗?", vbYesNo + vbSystemModal, "消息") If an = vbYes Then erg& = ExitWindowsEx(EWX_REBOOT, 0&) End If Case DISP_CHANGE_SUCCESSFUL erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY) MsgBox "一切正常!", vbOKOnly + vbSystemModal, "成功" Case Else MsgBox "显示模式不支持", vbOKOnly + vbSystemModal, "错误"End Select 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 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 DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL DevM.dmPelsWidth = X 'ScreenWidth DevM.dmPelsHeight = Y 'ScreenHeight DevM.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() 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("DISPLAY", 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 DeleteDC nDC End Sub
已经测试 Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As BooleanPrivate Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long Const CCDEVICENAME = 32Const CCFORMNAME = 32Const DM_PELSWIDTH = &H80000Const DM_PELSHEIGHT = &H100000 Private Type DEVMODEdmDeviceName As String * CCDEVICENAMEdmSpecVersion As IntegerdmDriverVersion As IntegerdmSize As IntegerdmDriverExtra As Integer dmFields As LongdmOrientation As IntegerdmPaperSize As IntegerdmPaperLength As IntegerdmPaperWidth As IntegerdmScale As IntegerdmCopies As IntegerdmDefaultSource As IntegerdmPrintQuality As IntegerdmColor As IntegerdmDuplex As IntegerdmYResolution As IntegerdmTTOption As IntegerdmCollate As Integer dmFormName As String * CCFORMNAMEdmUnusedPadding As IntegerdmBitsPerPel As IntegerdmPelsWidth As LongdmPelsHeight As LongdmDisplayFlags As LongdmDisplayFrequency As LongEnd TypeDim DevM As DEVMODE Sub ChangeRes(iWidth As Single, iHeight As Single)Dim a As BooleanDim i As Integeri = 0Doa = EnumDisplaySettings(0&, i, DevM)i = i + 1Loop Until (a = False) Dim b&DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT DevM.dmPelsWidth = iWidthDevM.dmPelsHeight = iHeight ChangeDisplaySettings DevM, 0End SubPrivate Sub Form_Load() Call ChangeRes(800, 600) End Sub
Public Const CCHDEVICENAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000Public Const CDS_UPDATEREGISTRY = 1
Public Const CDS_TEST = 2Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
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 * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End TypeDeclare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long
Option ExplicitDim nDisplay As Integer, devM() As DEVMODEPrivate Sub Command1_Click()
devM(List1.ListIndex).dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL If ChangeDisplaySettings(devM(List1.ListIndex), CDS_TEST) = 0 Then
MsgBox "测试成功!"
Else
MsgBox "测试失败!"
End If
End SubPrivate Sub Command2_Click()
devM(List1.ListIndex).dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL If ChangeDisplaySettings(devM(List1.ListIndex), 0) = 0 Then
MsgBox "设定成功!"
Else
MsgBox "设定失败!"
End If
End SubPrivate Sub Form_Load()
Dim HasMore As Long, i As Integer
i = 0
Do
ReDim Preserve devM(0 To i)
HasMore = EnumDisplaySettings(0, i, devM(i))
If HasMore = 0 Then Exit Do
If devM(i).dmBitsPerPel = 24 Then
List1.AddItem "全彩" & vbTab & _
devM(i).dmPelsWidth & vbTab & devM(i).dmPelsHeight
Else
List1.AddItem 2 ^ devM(i).dmBitsPerPel & vbTab & _
devM(i).dmPelsWidth & vbTab & devM(i).dmPelsHeight
End If
i = i + 1
Loop
nDisplay = i
End Sub
给你个例子
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
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
DevM.dmPelsWidth = X 'ScreenWidth
DevM.dmPelsHeight = Y 'ScreenHeight
DevM.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()
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("DISPLAY", 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
DeleteDC nDC
End Sub
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As BooleanPrivate Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long
Const CCDEVICENAME = 32Const CCFORMNAME = 32Const DM_PELSWIDTH = &H80000Const DM_PELSHEIGHT = &H100000
Private Type DEVMODEdmDeviceName As String * CCDEVICENAMEdmSpecVersion As IntegerdmDriverVersion As IntegerdmSize As IntegerdmDriverExtra As Integer
dmFields As LongdmOrientation As IntegerdmPaperSize As IntegerdmPaperLength As IntegerdmPaperWidth As IntegerdmScale As IntegerdmCopies As IntegerdmDefaultSource As IntegerdmPrintQuality As IntegerdmColor As IntegerdmDuplex As IntegerdmYResolution As IntegerdmTTOption As IntegerdmCollate As Integer
dmFormName As String * CCFORMNAMEdmUnusedPadding As IntegerdmBitsPerPel As IntegerdmPelsWidth As LongdmPelsHeight As LongdmDisplayFlags As LongdmDisplayFrequency As LongEnd TypeDim DevM As DEVMODE
Sub ChangeRes(iWidth As Single, iHeight As Single)Dim a As BooleanDim i As Integeri = 0Doa = EnumDisplaySettings(0&, i, DevM)i = i + 1Loop Until (a = False)
Dim b&DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
DevM.dmPelsWidth = iWidthDevM.dmPelsHeight = iHeight
ChangeDisplaySettings DevM, 0End SubPrivate Sub Form_Load()
Call ChangeRes(800, 600)
End Sub