Dzwebs.Net

撰写电脑技术杂文十余年

VBA改变显示器的分辨率

Admin | 2013-5-27 10:21:18 | 被阅次数 | 7637

温馨提示!

如果未能解决您的问题,请点击搜索;登陆可复制文章,点击登陆

  在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


该杂文来自: PowerPoint杂文

上一篇:ppt复制幻灯片没背景

下一篇:在幻灯片中粘贴文字后文本框宽度长度太长太大

网站备案号:

网站备案号:滇ICP备11001339号-7

版权属性:

Copyright 2007-2021-forever Inc. all Rights Reserved.

联系方式:

Email:dzwebs@126.com QQ:83539231 访问统计