VB中怎样设置分辩率

Question

VB中怎样实现设置分辩率

Answer 1

用API函数ChangeDisplaySettings、EnumDisplaySettings
Public Sub SetDisplayMode() '/设置屏幕的分辨率
  Dim aRet, bRet As Long  
  aRet = EnumDisplaySettings(0, -1, PreDevM) '/取得当前系统的显示模式
  If aRet = 0 Then MsgBox "Enum Function Failed!", vbInformation
  
  If PreDevM.dmPaperWidth = 800 Or PreDevM.dmPelsHeight = 600 Then
    IsSeted = False         '/设置改变变量为False,不用改变系统的分辨率
  Else
    DevM = PreDevM
    DevM.dmPelsWidth = 800
    DevM.dmPelsHeight = 600
    
    DevM.dmFields = 5767168     '/Change the dmPelsWidth,dmPelsHeight and dmDisplayFrequency
    
    bRet = ChangeDisplaySettings(DevM, 0)
    If bRet <> 0 Then MsgBox "Change Function Failed!", vbInformation
    IsSeted = True          '/设置改变变量为True,系统的分辨率已改变
  End If
  
End Sub

Answer 2

Option ExplicitPrivate Type GUID
    Data1 As Long
    Data2 As Long
    Data3 As Long
    Data4(8) As Byte
End Type
Private Declare Function CoCreateGuid Lib "ole32.dll" (pguid As GUID) As Long
Private Declare Function StringFromGUID2 Lib "ole32.dll" (rguid As Any, ByVal lpstrClsId As Long, ByVal cbMax As Long) As Long'/列举监视器的所有可设置值.
'/改变监视器的设置
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" _
       (lpDevMode As Any, ByVal dwFlags As Long) As Long
'/lpDevMode      设备名称,设置为0
'/dwflags        可以是以下几个设置值 _
                0   只改变目前屏幕设置值,不改变登录数据库中屏幕的设置值 _
                CDS_UPDATEREGISTRY     除了改变目前屏幕的设置值之外,也改变登录 _
                                       数据库中屏幕设置的值. _
                CDS_TEST               测试参数lpDevMode的设置值是否为系统接受.
'/返回值         =0 成功,=1必须重新开机方能生效;其它,表示失败.
'/---------------------------------------------------------------------------------
Private Const CDS_UPDATEREGISTRY = 1
Private Const CDS_TEST = 2
Private Const CCHFORMNAME = 32
Private Const CCHDEVICENAME = 32
Private Const DM_BITSPERPEL = &H40000
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000Private 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      '2^dmBitsPerPel=颜色数  8,16,24,32
        dmPelsWidth As Long          '设置屏幕宽
        dmPelsHeight As Long         '设置屏幕高
        dmDisplayFlags As Long
        dmDisplayFrequency As Long
End Type'
'改变屏幕设置
'/----------------------------------------------------------------------------
'SmSetDisplayMode
'入口参数: _
          Width    设置屏幕的宽度 _
          Height   设置屏幕的高度 _
          Color    设置的颜色数,如果 =-1,则只改变宽度和高度. _
                   =8  256色, =16  16位色, =24或32  真彩色.
'返回值   =0       成功 _
          =1       必须重新开机方能生效 _
          =其它    失败
'如:i=SetDisplayMode(800,600,16)Public Function SmSetDisplayMode(ByVal Width As Integer, ByVal Height As Integer, ByVal Color As Integer) As Long
  Dim NewDevMode As DEVMODE
  Dim pDevmode As Long
  Dim DevPlay As Long
  '/保存当前的屏幕宽度和高度
  With NewDevMode
        .dmSize = Len(NewDevMode)
       If Color = -1 Then
          '/如果COLOR=-1,则只改变屏幕的宽度和高度
          .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
       Else
         .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
         .dmBitsPerPel = Color
       End If
       .dmPelsWidth = Width
       .dmPelsHeight = Height
  End With
  '/对真彩设置.
  If NewDevMode.dmBitsPerPel = 24 Then
     '/*测试系统是否支持24位
     DevPlay = ChangeDisplaySettings(NewDevMode, CDS_TEST)
     '/如果24位测试不成功,则将色彩设置为32位
     If DevPlay <> 0 Then
        NewDevMode.dmBitsPerPel = 32
     End If
  End If
  
EndFun:
  SmSetDisplayMode = ChangeDisplaySettings(NewDevMode, CDS_UPDATEREGISTRY)
End Function