form1.frm

很好的教程原代码！

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5265
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7815
   LinkTopic       =   "Form1"
   ScaleHeight     =   5265
   ScaleWidth      =   7815
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "设置模式为640x480"
      Height          =   855
      Left            =   720
      TabIndex        =   2
      Top             =   3480
      Width           =   2775
   End
   Begin VB.ListBox List1 
      Height          =   1500
      Left            =   360
      TabIndex        =   0
      Top             =   960
      Width           =   6735
   End
   Begin VB.Label Label1 
      Caption         =   "显卡信息"
      Height          =   255
      Left            =   360
      TabIndex        =   1
      Top             =   600
      Width           =   1575
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const CDS_TEST = &H4

Private Type DISPLAY_DEVICE
    cb As Long
    DeviceName As String * 32
    DeviceString As String * 128
    StateFlags As Long
    DeviceID As String * 128
    DeviceKey  As String * 128
End Type

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
    dmICMMethod As Long 'NT 4.0以上版本
    dmICMIntent As Long 'NT 4.0以上版本
    dmMediaType As Long 'NT 4.0以上版本
    dmDitherType As Long 'NT 4.0以上版本
    dmReserved1 As Long 'NT 4.0以上版本
    dmReserved2 As Long 'NT 4.0以上版本
    dmPanningWidth As Long 'Win2000以上版本
    dmPanningHeight As Long 'Win2000以上版本
End Type

Private Declare Function ChangeDisplaySettingsEx Lib "user32" Alias _
    "ChangeDisplaySettingsExA" _
    (lpszDeviceName As Any, _
    lpDevMode As Any, _
    ByVal hWnd As Long, _
    ByVal dwFlags As Long, _
    lParam As Any) As Long

Private Declare Function EnumDisplayDevices Lib "user32" Alias _
    "EnumDisplayDevicesA" _
    (Unused As Any, _
    ByVal iDevNum As Long, _
    lpDisplayDevice As DISPLAY_DEVICE, _
    ByVal dwFlags As Long) As Boolean

Dim OldX As Long, OldY As Long, T As Long

Private Sub Command1_Click()
    '例子调用：改变为 640x480位
    Dim DD As DISPLAY_DEVICE, DevM As DEVMODE
    DevM.dmSize = Len(DevM)
    DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
    DevM.dmPelsWidth = 640
    DevM.dmPelsHeight = 480
    '改变分辨率
    Call ChangeDisplaySettingsEx(ByVal 0&, DevM, ByVal 0&, CDS_TEST, ByVal 0&)
    T = Timer
    Do: DoEvents: Loop Until Timer > T + 5
    DevM.dmPelsWidth = OldX
    DevM.dmPelsHeight = OldY
    Call ChangeDisplaySettingsEx(ByVal 0&, DevM, ByVal 0&, CDS_TEST, ByVal 0&)
End Sub

Private Sub Form_Load()
    Dim DD As DISPLAY_DEVICE, DevM As DEVMODE
    DD.cb = Len(DD)
    OldX = Screen.Width / Screen.TwipsPerPixelX
    OldY = Screen.Height / Screen.TwipsPerPixelY
    '列举显示模式
    If EnumDisplayDevices(ByVal 0&, 0, DD, ByVal 0&) Then
        Me.AutoRedraw = True
        List1.AddItem "Device String:" + Left$(DD.DeviceString, InStr(1, DD.DeviceString, Chr$(0)) - 1)
        List1.AddItem "Device Name:" + Left$(DD.DeviceName, InStr(1, DD.DeviceName, Chr$(0)) - 1)
        List1.AddItem "Device Key:" + Left$(DD.DeviceKey, InStr(1, DD.DeviceKey, Chr$(0)) - 1)
        List1.AddItem "Device ID:" + Left$(DD.DeviceID, InStr(1, DD.DeviceID, Chr$(0)) - 1)
    Else
        List1.AddItem "Error while retrieving Display Information"
    End If
End Sub