在office环境下,我们可以利用VBA调用window api来改变显示器的分辨率。这样我们就可以做到,在使用office的时候改变系统分辨率,在关闭office文件时,又恢复分辨率。
下面是具体的例子,希望对您有帮助。
'第一步,先定义变量
Private Const DM_BITSPERPEL = H40000
Private Const DM_PELSWIDTH = H80000
Private Const DM_PELSHEIGHT = H100000
Private Const CDS_UPDATEREGISTRY = H1
Private Const CDS_TEST = H4
Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DISP_CHANGE_RESTART = 1
Private Type DEVMODE
dmDeviceName(0 To 7) As Long
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dummy(0 To 29) As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
'第二步:Windows API定义
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" ( ByRef lpDevMode As Any, ByVal dwFlags As Long) As Long
Sub ChangeResolution(iFlag As Long)
Dim iWidth As Long
Dim iHeight As Long
Dim iRet As Long
Dim dm As DEVMODE
Select Case iFlag
Case 1
iWidth = 640
iHeight = 480
Case 2
iWidth = 800
iHeight = 600
Case 3
iWidth = 1024
iHeight = 768
Case Else
MsgBox "无此分辨率设定", vbExclamation
Exit Sub
End Select
dm.dmSize = Len(dm)
dm.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
dm.dmPelsWidth = iWidth
dm.dmPelsHeight = iHeight
iRet = ChangeDisplaySettings(dm, CDS_TEST)
Select Case iRet
Case DISP_CHANGE_RESTART
iRet = ChangeDisplaySettings(0, 0)
MsgBox "分辨率变更重新设定", vbExclamation
Case DISP_CHANGE_SUCCESSFUL
iRet = ChangeDisplaySettings(dm, CDS_UPDATEREGISTRY)
If iRet = DISP_CHANGE_SUCCESSFUL Then
MsgBox "分辨率变更", vbInformation
Else
iRet = ChangeDisplaySettings(0, 0)
MsgBox "分辨率变更失败", vbExclamation
End If
Case Else
iRet = ChangeDisplaySettings(0, 0)
MsgBox "分辨率变更失败", vbExclamation
End Select
End Sub
Sub auto_open()
ChangeResolution 2
End Sub
Sub auto_close()
ChangeResolution 3
End Sub