‘------------------设置屏幕的函数----------------- Public Function SetDispMode(Width As Integer, Height As Integer, Color As Integer) As Long SetDispMode 800, 600, 16
'************************************************************* '* 名称:WinMode '* 用途:改变分辨率 '************************************************************* Const SPI_GETWORKAREA = 48 Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As Long Const CCHDEVICENAME = 32 Const CCHFORMNAME = 32 Const DM_PELSWIDTH = &H80000 Const DM_PELSHEIGHT = &H100000 Const DM_BITSPERPEL = &H40000 ' Private Type winmode dmDeviceName As String * CCHDEVICENAME 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 * CCHFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (ByVal lpwinmode As Long, ByVal dwflags As Long) As Long '********************************************************* '* 名称:SetDisplayMode '* 功能:设置显示分辨率 '* 用法:SetDisplayMode() '********************************************************* Public Function SetDisplayMode(Width As Integer, Height As Integer, Color As Integer) As Long Dim Newwinmode As winmode Dim p As Long With Newwinmode .dmSize = 122 If Color = -1 Then .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Else .dmFields = DM_PELSWIDTH Or _ DM_PELSHEIGHT Or DM_BITSPERPEL End If .dmPelsWidth = Width .dmPelsHeight = Height
If Color <> -1 Then .dmBitsPerPel = Color End If End With p = lstrcpy(Newwinmode, Newwinmode) SetDisplayMode = ChangeDisplaySettings(p, 0) End Function
'以下这段代码你作为一个独立的的工程,加入到form中,运行便知结果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 Form_Load() 'KPD-Team 2000 'URL: http://www.allapi.net/ 'E-Mail: [email protected] Dim DD As DISPLAY_DEVICE, DevM As DEVMODE DD.cb = Len(DD) OldX = Screen.Width / Screen.TwipsPerPixelX OldY = Screen.Height / Screen.TwipsPerPixelY 'First retieve some display info If EnumDisplayDevices(ByVal 0&, 0, DD, ByVal 0&) Then 'and show it Me.AutoRedraw = True Me.Print "Device String:" + Left$(DD.DeviceString, InStr(1, DD.DeviceString, Chr$(0)) - 1) Me.Print "Device Name:" + Left$(DD.DeviceName, InStr(1, DD.DeviceName, Chr$(0)) - 1) Me.Print "Device Key:" + Left$(DD.DeviceKey, InStr(1, DD.DeviceKey, Chr$(0)) - 1) Me.Print "Device ID:" + Left$(DD.DeviceID, InStr(1, DD.DeviceID, Chr$(0)) - 1) Else Me.Print "Error while retrieving Display Information" End If DevM.dmSize = Len(DevM) 'we want to change the horizontal and the vertical resolution DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT DevM.dmPelsWidth = 640 DevM.dmPelsHeight = 480 'change the display settings 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 'change the display settings back to the old settings Call ChangeDisplaySettingsEx(ByVal 0&, DevM, ByVal 0&, CDS_TEST, ByVal 0&) End Sub
谢谢回复!谢谢zqfleaf(啊风),特别感谢lihonggen0(李洪根,用VB,标准答案来了), 按照Li的源码,我解决了问题,因此给Li Sir 40分, 给zqfleaf 10分, 并致谢意! 熊猫
这个函数怎么实现啊?
'* 名称:WinMode
'* 用途:改变分辨率
'*************************************************************
Const SPI_GETWORKAREA = 48
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As Long
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_BITSPERPEL = &H40000
'
Private Type winmode
dmDeviceName As String * CCHDEVICENAME
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 * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (ByVal lpwinmode As Long, ByVal dwflags As Long) As Long
'*********************************************************
'* 名称:SetDisplayMode
'* 功能:设置显示分辨率
'* 用法:SetDisplayMode()
'*********************************************************
Public Function SetDisplayMode(Width As Integer, Height As Integer, Color As Integer) As Long
Dim Newwinmode As winmode
Dim p As Long
With Newwinmode
.dmSize = 122
If Color = -1 Then
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
Else
.dmFields = DM_PELSWIDTH Or _
DM_PELSHEIGHT Or DM_BITSPERPEL
End If
.dmPelsWidth = Width
.dmPelsHeight = Height
If Color <> -1 Then
.dmBitsPerPel = Color
End If
End With
p = lstrcpy(Newwinmode, Newwinmode)
SetDisplayMode = ChangeDisplaySettings(p, 0)
End Function
'以下这段代码你作为一个独立的的工程,加入到form中,运行便知结果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 Form_Load()
'KPD-Team 2000
'URL: http://www.allapi.net/
'E-Mail: [email protected]
Dim DD As DISPLAY_DEVICE, DevM As DEVMODE
DD.cb = Len(DD)
OldX = Screen.Width / Screen.TwipsPerPixelX
OldY = Screen.Height / Screen.TwipsPerPixelY
'First retieve some display info
If EnumDisplayDevices(ByVal 0&, 0, DD, ByVal 0&) Then
'and show it
Me.AutoRedraw = True
Me.Print "Device String:" + Left$(DD.DeviceString, InStr(1, DD.DeviceString, Chr$(0)) - 1)
Me.Print "Device Name:" + Left$(DD.DeviceName, InStr(1, DD.DeviceName, Chr$(0)) - 1)
Me.Print "Device Key:" + Left$(DD.DeviceKey, InStr(1, DD.DeviceKey, Chr$(0)) - 1)
Me.Print "Device ID:" + Left$(DD.DeviceID, InStr(1, DD.DeviceID, Chr$(0)) - 1)
Else
Me.Print "Error while retrieving Display Information"
End If
DevM.dmSize = Len(DevM)
'we want to change the horizontal and the vertical resolution
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
DevM.dmPelsWidth = 640
DevM.dmPelsHeight = 480
'change the display settings
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
'change the display settings back to the old settings
Call ChangeDisplaySettingsEx(ByVal 0&, DevM, ByVal 0&, CDS_TEST, ByVal 0&)
End Sub
并致谢意!
熊猫