如何在vb中更改分辨率

API:好像是SetDisplay还是SetScreen,不是记得很清楚,你查一下MSDN就知道了

解决方案 »

  1.   

    Dim currate As String
    Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As Long
    Private Const CCHDEVICENAME = 32
    Private Const CCHFORMNAME = 32
    Private Const ENUM_CURRENT_SETTINGS = 1
    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 Long
            dmPelsWidth As Long
            dmPelsHeight As Long
            dmDisplayFlags As Long
            dmDisplayFrequency As Long
    End TypePrivate Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (ByVal lpDevMode As Long, ByVal dwflags As Long) As Long
    Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As Any) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As LongPrivate Const SM_CXSCREEN = 0
    Private Const SM_CYSCREEN = 1Dim pNewMode As DEVMODE
    Dim pOldMode As Long
    Dim nOrgWidth As Integer, nOrgHeight As Integer
        
    '设置显示器分辨率的执行函数
    Private Function SetDisplayMode(Width As Integer, Height As Integer, Color As Integer) As Long ', Freq As Long) As Long
        On Error GoTo ErrorHandler
        Const DM_PELSWIDTH = &H80000
        Const DM_PELSHEIGHT = &H100000
        Const DM_BITSPERPEL = &H40000
        Const DM_DISPLAYFLAGS = &H200000
        Const DM_DISPLAYFREQUENCY = &H400000
        With pNewMode
            .dmSize = Len(pNewMode)
            If Color = 0 Then 'Color = 0 时不更改屏幕颜色
                .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
            Else
                .dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT  'Or DM_DISPLAYFREQUENCY'属性率的更改还是没办法,不过,不加入此DM_DISPLAYFREQUENCY这个参数,只要系统支持,应该不会更改刷新率的
            End If
            .dmPelsWidth = Width
            .dmPelsHeight = Height
            If Color <> 0 Then
            .dmBitsPerPel = Color
            End If
        End With
        pOldMode = lstrcpy(pNewMode, pNewMode)
        SetDisplayMode = ChangeDisplaySettings(pOldMode, 1)
        Exit Function
    ErrorHandler:
        MsgBox Err.Description, vbCritical, "VB广场"
    End FunctionPrivate Sub Command1_Click()
        Dim nWidth As Integer, nHeight As Integer, nColor As Integer
        Select Case Combo1.ListIndex
            Case 0
                nWidth = 640: nHeight = 480: nColor = 16  '640*480*16位真彩色,256色nColor = 8,16色nColor = 4,nColor = 0 表示不改变颜色
            Case 1
                nWidth = 640: nHeight = 480: nColor = 24
            Case 2
                nWidth = 640: nHeight = 480: nColor = 32
            Case 3
                nWidth = 800: nHeight = 600: nColor = 16
            Case 4
                nWidth = 800: nHeight = 600: nColor = 24
            Case 5
                nWidth = 800: nHeight = 600: nColor = 32
            Case 6
                nWidth = 1024: nHeight = 768: nColor = 16
            Case 7
                nWidth = 1024: nHeight = 768: nColor = 24
            Case 8
                nWidth = 1024: nHeight = 768: nColor = 32
            Case 9
                nWidth = 1280: nHeight = 1024: nColor = 8
            Case other
                nWidth = 800: nHeight = 600: nColor = 16
        End Select
        SetKeyValue HKEY_LOCAL_MACHINE, "Config\0001\Display\Settings", "RefreshRate", Combo2.Text, REG_SZ
        Call SetDisplayMode(nWidth, nHeight, nColor)  '注意,系统不支持的显示模式不能选,否则,准备用安全模式重启动吧.API函数EnumDisplaySettings可以选择系统支持的模式,自己去写吧,也很简单.如果你还有什么问题,请给我发信或留言.
        SetKeyValue HKEY_LOCAL_MACHINE, "Config\0001\Display\Settings", "RefreshRate", Combo2.Text, REG_SZ
    End SubPrivate Sub Command2_Click()
        Unload Me
    End SubPrivate Sub Form_Load()Dim i As Integer, j As Integer
        Combo1.AddItem "640*480*16位真彩色"
        Combo1.AddItem "640*480*24位真彩色"
        Combo1.AddItem "640*480*32位真彩色"
        Combo1.AddItem "800*600*16位真彩色"
        Combo1.AddItem "800*600*24位真彩色"
        Combo1.AddItem "800*600*32位真彩色"
        Combo1.AddItem "1024*768*16位真彩色"
        Combo1.AddItem "1024*768*24位真彩色"
        Combo1.AddItem "1024*768*32位真彩色"
        Combo1.AddItem "1280*1024*256色"
        Combo1.Text = Combo1.List(0)
        nOrgWidth = GetDisplayWidth
        nOrgHeight = GetDisplayHeight
        'Combo2.Text =
        currate = QueryValue(HKEY_LOCAL_MACHINE, "Config\0001\Display\Settings", "RefreshRate")
        j = Combo2.ListCount
        For i = 0 To j
            If Val(currate) = Val(Combo2.List(i)) Then
                Combo2.Text = Combo2.List(i)
                Exit For
            End If
        Next
        nOrgWidth = GetSystemMetrics(SM_CXSCREEN) '两种获取初始屏幕大小的方法均可
        nOrgHeight = GetSystemMetrics(SM_CYSCREEN)
    End SubPrivate Function GetDisplayWidth() As Integer
        GetDisplayWidth = Screen.Width \ Screen.TwipsPerPixelX
    End FunctionPrivate Function GetDisplayHeight() As Integer
        GetDisplayHeight = Screen.Height \ Screen.TwipsPerPixelY
    End FunctionPrivate Sub RestoreDisplayMode()
        Call SetDisplayMode(nOrgWidth, nOrgHeight, 0)
    End Sub
    Private Sub Form_Unload(Cancel As Integer)
        RestoreDisplayMode
        SetKeyValue HKEY_LOCAL_MACHINE, "Config\0001\Display\Settings", "RefreshRate", currate, REG_SZ
    End Sub
      

  2.   

    请参考Public Declare Function lstrcpy _ 
    Lib "kernel32" Alias "lstrcpyA" _ 
    (lpString1 As Any, lpString2 As Any) _ 
    As Long 
    Public Const CCHDEVICENAME = 32 
    Public Const CCHFORMNAME = 32 
    Public 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 
    End Type 
    Public Declare Function ChangeDisplaySettings Lib "user32" Alias 
    "ChangeDisplaySettingsA" (ByVal lpDevMode As Long, ByVal dwflags As Long) As 
    Long 
    然后写一个小函数: 
    '- 函数 
    Public Function SetScreen(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 调用函数如下, SetScreen(800, 600, 16) 
    '设为800*600*(16色)
      

  3.   

    http://expert.csdn.net/Expert/topic/1447/1447078.xml?temp=.3613245