怎么实现当副显示器分辨率为1280*1024时，把它修改为1024*768
如何实现当副显示器分辨率为1280*1024时，把它修改为1024*768。
求实现以下功能的代码：
当副显示器分辨率为1280*1024时，把它修改为1024*768。
------解决思路----------------------
我没有测试。试试看：
------解决思路----------------------
在贴一个(你自己测试啊):
本帖最后由 fx35916 于 2015-10-20 16:25:08 编辑
一台主机接了两台显示器，一台是主显示器，另一台是副显示器。求实现以下功能的代码：
当副显示器分辨率为1280*1024时，把它修改为1024*768。
------解决思路----------------------
我没有测试。试试看：
Option Explicit
Const WM_DISPLAYCHANGE = &H7E
Const HWND_BROADCAST = &HFFFF&
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_BITSPERPEL = &H40000
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const CDS_UPDATEREGISTRY = &H1
Const CDS_TEST = &H4
Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
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
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 ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Dim OldX As Long, OldY As Long, nDC As Long
Dim OldXY As String
Public aPossible
Sub ChangeRes(X As Long, Y As Long, Bits As Long)
Dim DevM As DEVMODE, ScInfo As Long, erg As Long, an As VbMsgBoxResult
'Get the info into DevM
erg = EnumDisplaySettings(0&, 0&, DevM)
'This is what we're going to change
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
DevM.dmPelsWidth = X 'ScreenWidth
DevM.dmPelsHeight = Y 'ScreenHeight
DevM.dmBitsPerPel = Bits '(can be 8, 16, 24, 32 or even 4)
'Now change the display and check if possible
erg = ChangeDisplaySettings(DevM, CDS_TEST)
'Check if succesfull
Select Case erg&
Case DISP_CHANGE_RESTART
an = MsgBox("You've to reboot", vbYesNo + vbSystemModal, "Info")
If an = vbYes Then
erg& = ExitWindowsEx(EWX_REBOOT, 0&)
End If
Case DISP_CHANGE_SUCCESSFUL
erg = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
ScInfo = Y * 2 ^ 16 + X
'Notify all the windows of the screen resolution change
SendMessage HWND_BROADCAST, WM_DISPLAYCHANGE, ByVal Bits, ByVal ScInfo
MsgBox "Everything's ok", vbOKOnly + vbSystemModal, "It worked!"
Case Else
MsgBox "Mode not supported", vbOKOnly + vbSystemModal, "Error"
End Select
End Sub
Private Sub Command1_Click()
Dim sMyData As String
Dim iReply As Integer
Dim aXY As Variant
aXY = Array("", "")
sMyData = aPossible(List1.ListIndex + 1)
iReply = MsgBox("You have chosen:" + vbCrLf + sMyData, vbCritical + vbOKCancel)
If iReply = vbOK Then
aXY = Split(sMyData, "x")
aXY(0) = CInt(aXY(0))
aXY(1) = CInt(aXY(1))
' ChangeRes aXY(0), aXY(1), GetDeviceCaps(nDC, BITSPIXEL)
End If
End Sub
Private Sub Form_Load()
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
Dim nDC As Long
Dim sMyString As String
Dim bReturn As Boolean
Dim bFound As Boolean
Dim lX As Long
Dim iY As Integer 'resrved for the ordinal ubound of apossible
Dim iz As Integer
Dim DevM As DEVMODE
sMyString = "The current list" + vbCrLf + vbCrLf
sMyString = sMyString + "Screen Width:" + Str(Screen.Width) + vbCrLf
sMyString = sMyString + "Screen Height:" + Str(Screen.Height) + vbCrLf
sMyString = sMyString + "Screen TwipsPerPixelX:" + Str(Screen.TwipsPerPixelX) + vbCrLf
sMyString = sMyString + "Screen TwipsPerPixelY:" + Str(Screen.TwipsPerPixelY) + vbCrLf
'retrieve the screen's resolution
OldX = Screen.Width / Screen.TwipsPerPixelX
OldY = Screen.Height / Screen.TwipsPerPixelY
sMyString = sMyString + "X resolution:" + Str(OldX) + vbCrLf
sMyString = sMyString + "Y resolution:" + Str(OldY) + vbCrLf
' MsgBox sMyString
' Text2.Text = Trim$(Str(OldX))
' Text3.Text = Trim$(Str(OldY))
ReDim aPossible(1)
aPossible(0) = Trim$(Str$(OldX)) + " x " + Trim$(Str$(OldY))
Text4.Text = aPossible(0)
' MsgBox aPossible(0)
sMyString = ""
lX = 0
iY = 0
'Create a device context, compatible with the screen
nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
bReturn = True
While bReturn
bReturn = EnumDisplaySettings(0&, lX, DevM)
If bReturn Then 'ie. a valid entry
' sMyString = sMyString + Trim$(Str$(DevM.dmBitsPerPel)) + ":" + Trim$(Str$(DevM.dmPelsWidth)) + ":" + Trim$(Str$(DevM.dmPelsHeight)) + ":" + Str(lX) + vbCrLf
sMyString = Trim$(Str$(DevM.dmPelsWidth)) + " x " + Trim$(Str$(DevM.dmPelsHeight))
bFound = False
For iz = 0 To iY
If sMyString = aPossible(iz) Then
bFound = True
Exit For
End If
Next
If Not bFound Then
iY = iY + 1
ReDim Preserve aPossible(iY)
aPossible(iY) = sMyString
End If
lX = lX + 1 'Dont forget this
End If
Wend
sMyString = ""
For iz = 1 To iY
List1.AddItem aPossible(iz)
Next
' MsgBox sMyString
'Change the screen's resolution
' ChangeRes 640, 480, GetDeviceCaps(nDC, BITSPIXEL)
' Unload Me
End Sub
------解决思路----------------------
在贴一个(你自己测试啊):
Option Explicit
Dim bWindowsNT As Boolean
Const VER_PLATFORM_WIN32s = 0
Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VER_PLATFORM_WIN32_NT = 2
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_BITSPERPEL = &H40000
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const CDS_UPDATEREGISTRY = &H1
Const CDS_TEST = &H2
Const CDS_FULLSCREEN = &H4
Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
Const HWND_BROADCAST = &HFFFF&
Const WM_DISPLAYCHANGE = &H7E&
Const SPI_SETNONCLIENTMETRICS = 42
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 ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const ERROR_NOT_ALL_ASSIGNED = 1300
Const SE_PRIVILEGE_ENABLED = 2
Const TOKEN_QUERY = &H8
Const TOKEN_ADJUST_PRIVILEGES = &H20
Private Type LUID
lowpart As Long
highpart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges As LUID_AND_ATTRIBUTES
End Type
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPriv As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As Any, ByVal lpName As String, lpUid As LUID) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Sub cmdQuit_Click()
Unload Me
End Sub
Private Sub cmdChange_Click()
Dim DevM As DEVMODE
Dim lResult As Long
Dim iAns As Integer
lResult = EnumDisplaySettings(0, 0, DevM)
With DevM
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
If optRes(0) Then
.dmPelsWidth = 640
.dmPelsHeight = 480
ElseIf optRes(1) Then
.dmPelsWidth = 800
.dmPelsHeight = 600
Else
.dmPelsWidth = 1024
.dmPelsHeight = 768
End If
End With
lResult = ChangeDisplaySettings(DevM, CDS_FULLSCREEN)
Select Case lResult
Case DISP_CHANGE_RESTART
iAns = MsgBox("You must restart your computer to apply these changes." & _
vbCrLf & vbCrLf & "Do you want to restart now?", _
vbYesNo + vbSystemModal, "Screen Resolution")
If iAns = vbYes Then Call ExitWindowsEx(EWX_REBOOT, 0)
Case DISP_CHANGE_SUCCESSFUL
Call ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
Call SendMessage(HWND_BROADCAST, WM_DISPLAYCHANGE, SPI_SETNONCLIENTMETRICS, ByVal 0&)
MsgBox "Screen resolution changed", vbInformation, "Resolution Changed"
Case Else
MsgBox "Mode not supported", vbSystemModal, "Error"
End Select
End Sub
Private Sub cmdReboot_Click()
Dim tLuid As LUID
Dim tTokenPriv As TOKEN_PRIVILEGES
Dim tPrevTokenPriv As TOKEN_PRIVILEGES
Dim lResult As Long
Dim lToken As Long
Dim lLenBuffer As Long
Dim lMode As Long
If optShut(0) Then
lMode = EWX_LOGOFF
ElseIf optShut(1) Then
lMode = EWX_REBOOT
ElseIf optShut(2) Then
lMode = EWX_SHUTDOWN
Else: lMode = EWX_FORCE
End If
If Not bWindowsNT Then
Call ExitWindowsEx(lMode, 0)
Else
lResult = OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, lToken)
If lResult = 0 Then
Exit Sub
End If
lResult = LookupPrivilegeValue(0&, "SeShutdownPrivilege", tLuid)
If lResult = 0 Then Exit Sub
With tTokenPriv
.PrivilegeCount = 1
.Privileges.Attributes = SE_PRIVILEGE_ENABLED
.Privileges.pLuid = tLuid
lResult = AdjustTokenPrivileges(lToken, False, tTokenPriv, Len(tPrevTokenPriv), tPrevTokenPriv, lLenBuffer)
End With
If lResult = 0 Then
Exit Sub
Else
If Err.LastDllError = ERROR_NOT_ALL_ASSIGNED Then Exit Sub 'Failed
End If
Call ExitWindowsEx(lMode, 0)
End If
End Sub
Private Sub Command1_Click()
End Sub
Private Sub Form_Load()
Dim OSInfo As OSVERSIONINFO
OSInfo.dwOSVersionInfoSize = Len(OSInfo)
Call GetVersionEx(OSInfo)
bWindowsNT = (OSInfo.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Sub