|
Option Explicit
Const BITSPIXEL = 12
Const HORZRES = 8
Const VERTRES = 10
Const VREFRESH = 116
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_BITSPERPEL = &H40000
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_DISPLAYFREQUENCY = &H400000
Const CDS_UPDATEREGISTRY = &H1
Const CDS_TEST = &H2
Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
Const DISP_CHANGE_FAILED = -1
Const DISP_CHANGE_BADMODE = -2
Const DISP_CHANGE_NOTUPDATED = -3 'Nur NT!
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
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 GetDeviceCaps Lib "gdi32" (ByVal hdc _
As Long, ByVal nIndex As Long) As Long
Dim DevM As DEVMODE
Private Sub Form_Load()
Dim bResult As Boolean, AddString As String
Dim i As Long
Do
bResult = EnumDisplaySettings(0&, i&, DevM)
If bResult = False Then Exit Do
AddString = DevM.dmPelsWidth & " x " & DevM.dmPelsHeight & ", "
If DevM.dmBitsPerPel = 16 Then
AddString = AddString & "High Color (16 Bit)"
ElseIf DevM.dmBitsPerPel = 32 Then
AddString = AddString & "True Color (32 Bit)"
Else
AddString = AddString & Format$(2 ^ DevM.dmBitsPerPel, _
"#,#") & " Farben"
End If
lstSettings.AddItem AddString
i = i + 1
Loop
RefreshInfo
End Sub
Sub RefreshInfo()
Dim bpp As Long, x As Long, y As Long, freq As Long
bpp = GetDeviceCaps(Me.hdc, BITSPIXEL)
x = GetDeviceCaps(Me.hdc, HORZRES)
y = GetDeviceCaps(Me.hdc, VERTRES)
freq = GetDeviceCaps(Me.hdc, VREFRESH)
label1.Caption = "Auflösung: " & x & " x " & y & " Pixel"
label2.Caption = "Bit pro Pixel: " & bpp & _
" (" & Format$(2 ^ bpp, "#,#") & " Farben)"
If freq > 1 Then
lblFrequenz = lblFrequenz.Caption & Str$(freq) & " Hz"
Else
lblFrequenz.Caption = lblFrequenz.Caption & _
"(Hardware-Default)"
End If
End Sub
Private Sub Command1_Click(Index As Integer)
Select Case Index
Case 1
If MsgBox("Möchten Sie die Auflösung wirklich in " & _
lstSettings.Text & " ändern?", 48 + vbYesNo) = _
vbYes Then
EnumDisplaySettings 0&, lstSettings.ListIndex, DevM
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or _
DM_BITSPERPEL Or DM_DISPLAYFREQUENCY
Select Case ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
Case DISP_CHANGE_SUCCESSFUL
MsgBox "Auflösung erfolgreich geändert.", 64
Case DISP_CHANGE_RESTART
MsgBox "Zum Ändern der Auflösung muß der " & _
"Computer neu gestartet werden.", 64
Case DISP_CHANGE_FAILED
MsgBox "Die Auflösung konnte nicht geändert " & _
"werden.", 64
Case DISP_CHANGE_BADMODE
MsgBox "Grafikmodus wird nicht unterstützt.", 64
Case DISP_CHANGE_NOTUPDATED
MsgBox "Die Einstellungen konnten nicht in der " & _
"Registry gespeichert werden.", 64
End Select
RefreshInfo
End If
Case Else
Unload Me
End
End Select
End Sub
|
|