Private Sub cmdSetSize_Click()
Dim txt As String
Dim wid As Integer
Dim hgt As Integer
Dim bpp As Integer
Dim dev_mode As DEVMODE
Dim result As Long
' Get the desired values.
txt = cboDisplaySize.Text
wid = CLng(Split(txt, "x")(0))
txt = Split(txt, "x")(1)
hgt = CLng(Split(txt, "(")(0))
txt = Split(txt, "(")(1)
bpp = CLng(Split(txt, " ")(0))
' Test the desired mode.
If SetDisplayMode(wid, hgt, bpp, CDS_TEST) = _
DISP_CHANGE_SUCCESSFUL Then
' The test worked. Make the change.
SetDisplayMode wid, hgt, bpp, CDS_UPDATEREGISTRY
End If
End Sub
' Set the indicated display size and color depth.
Private Function SetDisplayMode(ByVal wid As Long, ByVal _
hgt As Long, ByVal bpp As Long, ByVal change_flags As _
Long) As Long
Dim dev_mode As DEVMODE
Dim result As Long
' Set the desired mode.
With dev_mode
.dmSize = Len(dev_mode)
.dmDriverExtra = 0
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or _
DM_BITSPERPEL
.dmPelsWidth = wid
.dmPelsHeight = hgt
.dmBitsPerPel = bpp
End With
' Make the change.
result = ChangeDisplaySettings(dev_mode, change_flags)
Select Case result
Case DISP_CHANGE_BADFLAGS
MsgBox "Invalid flags in ChangeDisplaySettings"
Case DISP_CHANGE_BADMODE
MsgBox "Graphics mode not supported"
Case DISP_CHANGE_BADPARAM
MsgBox "Invalid parameter to " & _
"ChangeDisplaySettings"
Case DISP_CHANGE_FAILED
MsgBox "Display driver failed in specific " & _
"graphics mode in ChangeDisplaySettings"
Case DISP_CHANGE_NOTUPDATED
MsgBox "Unable to write changes to Registry in " & _
"ChangeDisplaySettings"
Case DISP_CHANGE_RESTART
MsgBox "Restart required before changes can " & _
"take effect"
Case DISP_CHANGE_SUCCESSFUL
' It worked.
End Select
SetDisplayMode = result
End Function
|
