请问如何在VB程序中修改分辨率？？

Question

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 Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32
Private Const DM_BITSPERPEL = &H40000
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000
Private Const CDS_UPDATEREGISTRY = &H1
Private Const CDS_TEST = &H4
Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DISP_CHANGE_RESTART = 1
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
'ExamplePrivate Sub Form_Load()'Changes the resolution to 640x480 with the current colordepth.Dim DevM As DEVMODE '注释：Get the info into
DevMerg& = EnumDisplaySettings(0&, 0&, DevM) '注释：We don't change the colordepth, because a reboot will be necessary
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
DevM.dmPelsWidth = 800 'ScreenWidth
DevM.dmPelsHeight = 600 'ScreenHeight
DevM.dmBitsPerPel = 8 '(could be 8, 16, 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)
    MsgBox "Everythings ok", vbOKOnly + vbSystemModal, "It worked!"
Case Else
    MsgBox "Mode not supported", vbOKOnly + vbSystemModal, "Error"
End Select
End Sub

Answer 1

多谢dbcontrols(泰山)　
我先试试看

Answer 2

dbcontrols(泰山)　：
请说明一下具体的用法。

Answer 3

Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _
    (lpString1 As Any, _
    lpString2 As Any _
    ) As Long
Private Declare Function ChangeDisplaySettings Lib "User32" Alias "ChangeDisplaySettingsA" _
    (ByVal lpDevMode As Long, _
    ByVal dwflags As Long _
    ) As Long
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Private Type 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 Type
' 动态改变屏幕设置的函数
Public Function SetDisplayMode(Width As Integer, Height As Integer, Color As Integer) As Long
    Const DM_PELSWIDTH = &H80000
    Const DM_PELSHEIGHT = &H100000
    Const DM_BITSPERPEL = &H40000
    Dim NewDevMode As DEVMODE
    Dim pDevmode As Long
    With NewDevMode
        .dmSize = 122
        If Color = -1 Then
            .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
        Else
            .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
        End If
        .dmPelsWidth = Width
        .dmPelsHeight = Height
        If Color <> -1 Then
        .dmBitsPerPel = Color
        End If
    End With
    pDevmode = lstrcpy(NewDevMode, NewDevMode)
    SetDisplayMode = ChangeDisplaySettings(pDevmode, 0)
End Function
Private Sub Command1_Click()
    '例子调用：改变为 640x480x24位：
    Dim i As Long
    i = SetDisplayMode(640, 480, 24)
End Subsetdisplaymode有3个参数，width为屏幕的宽度，height为屏幕的高度，color为屏幕的颜色，例如要改为640x480x24位则
    Dim i As Long
    i = SetDisplayMode(640, 480, 24)
调用后，不需重新启动计算机，屏幕的设置会自动改变！
ok！

Answer 4

to:
Samurai(魂
好像不会改变，我的系统是windows2000server,为什么？

Answer 5

新建一个工程,窗体,把代码
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 Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32
Private Const DM_BITSPERPEL = &H40000
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000
Private Const CDS_UPDATEREGISTRY = &H1
Private Const CDS_TEST = &H4
Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DISP_CHANGE_RESTART = 1
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
'Example
拷贝进去,在Form_Load里面
Dim DevM As DEVMODE '注释：Get the info into
DevMerg& = EnumDisplaySettings(0&, 0&, DevM) '注释：We don't change the colordepth, because a reboot will be necessary
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
DevM.dmPelsWidth = 800 'ScreenWidth
DevM.dmPelsHeight = 600 'ScreenHeight
DevM.dmBitsPerPel = 8 '(could be 8, 16, 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)
Case Else
End Select在Form_UnLoad里面
Dim DevM As DEVMODE '注释：Get the info into
DevMerg& = EnumDisplaySettings(0&, 0&, DevM) '注释：We don't change the colordepth, because a reboot will be necessary
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
DevM.dmPelsWidth = 1024 'ScreenWidth
DevM.dmPelsHeight = 768 'ScreenHeight
DevM.dmBitsPerPel = 8 '(could be 8, 16, 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)
    Case Else
    End Select
可以结贴给分了,我要120

Answer 6

to dbcontrols(泰山)　
难道你的程序从来不要 “Option Explicit ”这句嘛
这段程序把color改成256色了，本来是增强16位的
分等下给你

Answer 7

多谢
dbcontrols(泰山)
结账了!!!

Answer 8

DevM.dmBitsPerPel = 8 '(could be 8, 16, 32 or even 4)
这句改变分辨率

Answer 9

是颜色
Option Explicit 是强调声明变量的,我很少用.