On 18 Feb 2004 06:26:09 -0800, dyl@city.dk (Bjarne Warlund) wrote:
>Hej kloge hoveder.
>
>Jeg kender _intet_ til programmering, men kunne godt bruge een fil som
>ved dobbeltklik ændrer skærmopløsningen fra 800 *600 til 1024 * 768,
>og omvendt. - Måske vha. 2 filer - een som forstørrer og een som
>formindsker.
>
>Nogen der har et bud, eller mod på at oprette det?
Denne kode har jeg benyttet i en Access-app til at ændre
skærmopløsning. Du kan jo blot checke for om skærmopløsningen er det
ene eller andet, og så skifte...
Jeg kan ikke huske hvorfra jeg har koden, men ved jeg har filet den
lidt til, så den passede til egne behov - men den skulle vist være til
at gå til.
mvh /Snedker
'---kode start
Option Compare Database
Option Explicit
Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000
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 apiEnumDisplaySettings Lib "user32" Alias
"EnumDisplaySettingsA" _
(ByVal lpszDeviceName As Long, ByVal iModeNum As Long,
lpDevMode As Any) As Boolean
Private Declare Function apiChangeDisplaySettings Lib "user32" Alias
"ChangeDisplaySettingsA" _
(lpDevMode As Any, ByVal dwflags As Long) As Long
'Following used by function ShowResolution()
Type RECT
x1 As Long 'left
y1 As Long 'top
x2 As Long 'right
y2 As Long 'bottom
End Type
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function GetWindowRect Lib "user32" (ByVal Hwnd As Long,
lpRect As RECT) As Long
Public Fejl As String
Public Focus As Boolean 'if sub-forms has focus
Public ScrChanged As Boolean
Public OrigRes As String
Function fchangeres(intx As Integer, intY As Integer) As Boolean
ScrChanged = False
Dim tDevMode As DEVMODE
Dim boolCanChange As Boolean
Dim boolRet As Boolean
Dim lngRet As Long, lngMode As Long
On Error GoTo Err_Handler
Do
boolRet = apiEnumDisplaySettings(0&, lngMode&, tDevMode)
With tDevMode
If .dmPelsWidth = intx And .dmPelsHeight = intY Then
boolCanChange = True
End If
End With
lngMode = lngMode + 1
Loop Until boolRet = False
If boolCanChange Then
With tDevMode
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
.dmPelsWidth = intx
.dmPelsHeight = intY
End With
lngRet = apiChangeDisplaySettings(tDevMode, 0&)
End If
fchangeres = boolCanChange
exit_Handler:
Exit Function
Err_Handler:
fchangeres = False
Resume exit_Handler
End Function
Function fEnumDisplay() As Collection
Dim collRes As Collection
Dim boolRet As Boolean
Dim tDevMode As DEVMODE
Dim lngMode As Long
Set collRes = New Collection
Do
boolRet = apiEnumDisplaySettings(0&, lngMode&, tDevMode)
With tDevMode
collRes.Add .dmPelsWidth & "x" & _
.dmPelsHeight & " @ " & .dmBitsPerPel & " bit", _
lngMode & vbNullString
End With
lngMode = lngMode + 1
Loop Until boolRet = False
Set fEnumDisplay = collRes
Set collRes = Nothing
End Function
Function showresolution() As String
Dim x As Boolean
Dim R As RECT
Dim Hwnd As Long
Dim RetVal As Long
Dim intx As Integer
Dim intZ As Integer
Dim Output As String
Hwnd = GetDesktopWindow()
RetVal = GetWindowRect(Hwnd, R)
showresolution = (R.x2 - R.x1) & "x" & (R.y2 - R.y1)
OrigRes = showresolution
If showresolution = "640x480" Then
x = fchangeres(800, 600)
ScrChanged = True
End If
End Function
'---kode slut
---
http://dbconsult.dk