AW: Zoom automatisch an Bildschirmeinst. anpassen?
28.09.2005 17:40:42
Rene
ich habe da was für dich, müsstest du nur noch gekonnt einbinden
' zunächst die benötigten API-Deklarationen
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
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 Const DM_BITSPERPEL = &H40000
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000
Private Const DM_DISPLAYFREQUENCY = &H400000
Private Const CDS_UPDATEREGISTRY = &H1
Private Const CDS_TEST = &H2
Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DISP_CHANGE_RESTART = 1
Private Const DISP_CHANGE_FAILED = -1
Private Const DISP_CHANGE_BADMODE = -2
Private Const DISP_CHANGE_NOTUPDATED = -3 'Nur NT!
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const BITSPIXEL = 12
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
Aktuelle Bildschirm-Einstellungen ermitteln
' aktuelle Bildschirm-Einstellungen ermitteln
' x, y = Auflösung
' Colors = Farbtiefe (4,8,16,24,32)
Public Sub GetCurrentSettings(ByVal hDC As Long, _
x As Integer, y As Integer, Colors As Integer)
x = Screen.Width / Screen.TwipsPerPixelX
y = Screen.Height / Screen.TwipsPerPixelY
Colors = GetDeviceCaps(hDC, BITSPIXEL)
End Sub
Ändern der Auflösung und der eingestellten Farbtiefe
' neue Bildschirm-Einstellung setzen
' x,y = neue Auflösung
' Colors = neue Farbtiefe
' 4 = 16 Farben
' 8 = 256 Farben
' 16 = HighColor
' 24 = 24-Bit
' 32 = TrueColor
Public Sub ChangeSettings(ByVal hDC As Long, _
x As Integer, y As Integer, Colors As Integer)
Dim lResult As Long
Dim lIndex As Long
Dim DevM As DEVMODE
With DevM
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or _
DM_BITSPERPEL Or DM_DISPLAYFREQUENCY
.dmPelsWidth = x
.dmPelsHeight = y
.dmBitsPerPel = Colors
End With
lResult = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
Select Case lResult
Case DISP_CHANGE_RESTART
If MsgBox("Damit die eingestellte Auflösung " & _
"wirksam wird, ist es notwendig, daß Windows " & _
"neu gestartet wird.", 65) = vbOK Then
RebootSystem EWX_REBOOT
End If
Case DISP_CHANGE_FAILED
MsgBox "Die Auflösung konnte nicht " & _
"geändert werden.", 64
Case DISP_CHANGE_BADMODE
MsgBox "Der geforderte Grafikmodus wird " & _
"von Ihrem System nicht unterstützt.", 64
Case DISP_CHANGE_NOTUPDATED
MsgBox "Die neuen Einstellungen konnten " & _
"nicht in der Registry gespeichert werden.", 64
End Select
End Sub
So, mit den obigen Routinen lässt sich doch schon mal einiges anfangen. Um nun beim Programmstart die Mindestanforderungen zu prüfen und ggf. die Einstellungen zu ändern, hier ein Beispiel:
' Prüfen der Einstellungen
Private Sub Form_Load()
Dim x As Integer
Dim y As Integer
Dim Colors As Integer
' Ermitteln der aktuellen Einstellungen
GetCurrentSettings Me.hDC, x, y, Colors
' Mindestanforderung:
' 800x600 bei 16bit Farbtiefe (TrueColor)
If x < 800 Or y < 600 Or Colors < 16 Then
' Mindestanforderung nicht erfüllt
If MsgBox("Für den korrekten Ablauf der " & _
"Anwendung muß eine Bildschirm-Auflösung " & _
"von mind. 800x600 bei einer Farbtiefe von " & _
"16Bit (TrueColor) eingestellt sein!" & _
vbCrLf & vbCrLf & _
"Einstellungen entsprechend ändern?", _
35) = vbYes Then
' Einstellung ändern
ChangeSettings Me.hDC, 800, 600, 16
Else
' Programm beenden
End
End If
End If
End Sub
Weiteres Beispiel
Und nun zum eingangs erwähnten Beispiel, bei welchem alle vom System unterstützten Bildschirm-Einstellungen in einer Liste angezeigt werden sollen. Per Doppelklick auf einen Listen-Eintrag sollen die Einstellungen dann entsprechend neu gesetzt werden.
Um das nachfolgende Beispiel ausprobieren zu können, starten Sie ein neues Projekt, plazieren auf die Form eine ListBox List1 und fügen im Allgemein-Teil der Form1 alle notwendigen API-Deklarationen ein (siehe ganz vorne).
' Alle unterstützen Bildschirm-Modi ermitteln
Public Sub GetAllScreenModes(List As ListBox)
Dim lResult As Long
Dim i As Long
Dim DevM As DEVMODE
Dim Res As String
Dim Colors As String
' Liste aller unterstützen Device-Modi erstellen
List.Clear
i = 0
Do
lResult = EnumDisplaySettings(0&, i, DevM)
If lResult = 0 Then Exit Do
With DevM
' Auflösung
Res = .dmPelsWidth & " x " & .dmPelsHeight
' Farbtiefe
If .dmBitsPerPel = 4 Then
Colors = "16 Farben"
ElseIf .dmBitsPerPel = 8 Then
Colors = "256 Farben"
ElseIf .dmBitsPerPel = 16 Then
Colors = "HighColor"
ElseIf .dmBitsPerPel = 24 Then
Colors = "24-Bit"
ElseIf .dmBitsPerPel = 32 Then
Colors = "TrueColor"
End If
List.AddItem Format$(i, "0") & " - " & Res & _
", " & Colors & " (" & .dmDisplayFrequency & _
" Hz)"
End With
i = i + 1
Loop
End Sub
' Beim Laden der Form, Liste füllen
Private Sub Form_Load()
GetAllScreenModes List1
End Sub
' Einstellungen ändern
Private Sub List1_Click()
Dim lResult As Long
Dim lIndex As Long
Dim DevM As DEVMODE
lIndex = List1.ListIndex
lResult = EnumDisplaySettings(0&, lIndex, DevM)
If lResult = 0 Then Exit Sub
' Mitteilen, welche Einstellungen geändert werden
' sollen (Auflösung + Farbtiefe + Frequenz)
With DevM
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or _
DM_BITSPERPEL Or DM_DISPLAYFREQUENCY
End With
lResult = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
Select Case lResult
Case DISP_CHANGE_RESTART
If MsgBox("Damit die eingestellte Auflösung " & _
"wirksam wird, ist es notwendig, daß Windows " & _
"neu gestartet wird.", 65) = vbOK Then
RebootSystem EWX_REBOOT
End If
Case DISP_CHANGE_FAILED
MsgBox "Die Auflösung konnte nicht " & _
"geändert werden.", 64
Case DISP_CHANGE_BADMODE
MsgBox "Der geforderte Grafikmodus wird " & _
"von Ihrem System nicht unterstützt.", 64
Case DISP_CHANGE_NOTUPDATED
MsgBox "Die neuen Einstellungen konnten " & _
"nicht in der Registry gespeichert werden.", 64
End Select
End Sub