ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 13899|回复: 12

[分享] 自动关闭的Msgbox

[复制链接]

TA的精华主题

TA的得分主题

发表于 2015-10-31 15:02 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:Windows API应用
本帖最后由 joforn 于 2018-2-9 17:43 编辑

有许多论友比较喜欢能自动关闭的Msgbox信息框,一般常见方式是调用Wscript.Shell对象的POPUP方法实现,如下面的代码:

  1.     Dim wShell As Object
  2.     Set wShell = CreateObject("Wscript.Shell")  '创建对象
  3.     wShell.popup "执行完毕!", 2, "提示", 64      '执行popup方法,实现Msgbox信息框弹出
  4.     Set wShell = Nothing                                '释放对象
复制代码

但上面的方式可能有时会有些问题,比如:
一、有时会无法自动在指定的时间后自动自闭弹出的信息框;
二、在有些系统上可能会出现CreateObject("Wscript.Shell")失败而返回Nothing,这样的话信息框都不会弹出;
三、信息框弹出后,在信息框关闭前仍可以操作Excel中的工作簿窗体,在某些特定的情况可能会导致严重错误。

其实,要实现自动关闭的Msgbox只要调用API MessgeBoxTimeOut就可以很简单的实现了。顺便说下为什么VBA中没有一个类似MsgboxTimeOut的函数呢,这是因为VBA中的函数都是从VB6中继承来的,但是VB6生产于Windows 98时代,而MessgeBoxTimeOut这个API函数最早出现于Windows XP,所以VBA中自然就没有这个函数了。虽说现在VBA7版本出来了,但是它似乎仅仅是为了让VBA原有的功能可在后续的Windows版本中继续运行而已,故而没有新增什么东西。
下面的模块代码可用来替换掉VBA中原有的Msgbox函数(此处下载模块文件):

  1. Option Explicit
  2. '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  3. '>>>>>>>>   Author:     Joforn                            <<<<<<<<<<<<<<<<<<
  4. '>>>>>>>>   Email:      Joforn@sohu.com                   <<<<<<<<<<<<<<<<<<
  5. '>>>>>>>>   QQ:         42978116                          <<<<<<<<<<<<<<<<<<
  6. '>>>>>>>>   Last time : 10/31/2015                        <<<<<<<<<<<<<<<<<<
  7. '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<


  8. #If VBA7 Then
  9.   Private Declare PtrSafe Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutW" ( _
  10.     ByVal hWnd As Long, ByVal lpText As LongPtr, _
  11.     ByVal lpCaption As LongPtr, ByVal wType As Long, _
  12.     ByVal wLange As Long, ByVal dwTimeout As Long) As Long
  13. #Else
  14.   Private Declare Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutW" ( _
  15.     ByVal hWnd As Long, ByVal lpText As Long, _
  16.     ByVal lpCaption As Long, ByVal wType As Long, _
  17.     ByVal wLange As Long, ByVal dwTimeout As Long) As Long
  18. #End If
  19. Private lngTimeOut As Long

  20. Public Property Let MsgboxTimeOutSecond(ByVal TimeOut As Long)
  21.   On Error GoTo LetSecondError
  22.   If TimeOut < 0 Then
  23.     lngTimeOut = 0
  24.   Else
  25.     lngTimeOut = TimeOut * 1000
  26.   End If
  27.   Exit Property
  28. LetSecondError:
  29.   lngTimeOut = &H7FFFFFFF
  30. End Property

  31. Public Property Let MsgboxTimeOut(ByVal TimeOut As Long)
  32.   If TimeOut < 0 Then
  33.     lngTimeOut = 0
  34.   Else
  35.     lngTimeOut = TimeOut
  36.   End If
  37. End Property

  38. Public Property Get MsgboxTimeOut() As Long
  39.   MsgboxTimeOut = lngTimeOut
  40. End Property

  41. Public Function Msgbox(ByVal Prompt As String, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
  42.                  Optional ByVal Title As String = vbNullString, Optional ByVal TimeOut As Long = -1&, _
  43.                  Optional ByVal LangeId As Long = 0&) As VbMsgBoxResult
  44.   'TimeOut以毫秒为单位,1 second = 1000 ms,TimeOut值为0时表示不自动返回,为负值时表示使用全局默认值
  45.   '如果信息框弹出后,用户未点击任何按钮,将返回3200,但如果Buttons的按钮值为VbOkOnly时,返回VbOk
  46.   
  47.   If TimeOut < 0 Then TimeOut = lngTimeOut
  48.   If Len(Title) < 1 Then Title = Application.Caption
  49.   Msgbox = MessageBoxTimeout(Application.hWnd, StrPtr(Prompt), StrPtr(Title), Buttons Or &H2000&, LangeId, TimeOut)
  50. End Function
复制代码

说明:
一、MsgboxTimeOutSecondMsgboxTimeOut两个属性只是为了方便大家设置全局默认自动关闭时间用的,这两个属性对应同一个值,但是是两个不同的单位:MsgboxTimeOut的单位值是毫秒,而MsgboxTimeOutSecond的单位是,这是为了方便有搞不清单位换算的筒子用的。但这两个属性设置的值只有在Msgbox省略TimeOut参数或是TimeOut参数值为负数时有效。为什么会添加这两个属性呢,主要是考虑到如果原有工程代码中有大量Msgbox要全部设置为自动关闭而增加的,因为有了它们,只要在工程运行的最开始处(比如:Workbook_Open事件处理过程)添加一条如MsgboxTimeOut = 1000这样的代码就可以轻松将所有的Msgbox指定为1秒后自动关闭,而不用再去修改原有代码;
二、Msgbox函数取消了原有系统自带Msgbox函数中的两个与帮助相关的参数(估计多数人都从来不用这个两参数,至少本人就极少用到^_^);
三、本函数弹出的信息框样式是Windows 98样式,如果有不喜欢这个Style的筒子,请使用其它的方式来实现;
四、导入本模块后,可能会影响到其它的工作簿的Msgbox的Style,但不影响其正常功能;
五、如果你的程序将会在Windows 2000、98系统或是更低的Windows版本中运行,请不要使用本函数!!!

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2015-10-31 15:57 | 显示全部楼层
还是用窗体自己做个比较好,各个位置各种样式都能设置,用 DO LOOP +TIMER 做个定时就好了。

TA的精华主题

TA的得分主题

发表于 2017-9-4 08:39 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
谢谢   分享

TA的精华主题

TA的得分主题

发表于 2018-1-29 19:45 | 显示全部楼层
Private Sub CommandButton1_Click()
CreateObject("WScript.Shell").Popup "Auto Close Me", 1, "Microsoft Excel", 0 + 64
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-1-29 19:57 | 显示全部楼层
bangyou 发表于 2018-1-29 19:45
Private Sub CommandButton1_Click()
CreateObject("WScript.Shell").Popup "Auto Close Me", 1, "Microso ...

您是想说您的代码更简单对么?
如果是的话,在此表示万分的感谢!

TA的精华主题

TA的得分主题

发表于 2019-5-10 18:21 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
又学习了,新的自动关闭方法

TA的精华主题

TA的得分主题

发表于 2019-8-5 14:43 | 显示全部楼层
感谢,对我很有用,不用改动以前的代码就可以直接自动关闭了

代码的部分的use**** 应该是user32,这里研究了半小时才搞清楚。

TA的精华主题

TA的得分主题

发表于 2020-12-22 11:52 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-6-13 15:17 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-6-26 08:34 | 显示全部楼层

  1. Option Explicit
  2. '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  3. '>>>>>>>>   Author:     Joforn                            <<<<<<<<<<<<<<<<<<
  4. '>>>>>>>>   Email:      [email]Joforn@sohu.com[/email]                   <<<<<<<<<<<<<<<<<<
  5. '>>>>>>>>   QQ:         42978116                          <<<<<<<<<<<<<<<<<<
  6. '>>>>>>>>   Last time : 10/31/2015                        <<<<<<<<<<<<<<<<<<
  7. '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<


  8. #If VBA7 Then
  9.   Private Declare PtrSafe Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutW" ( _
  10.     ByVal hWnd As Long, ByVal lpText As LongPtr, _
  11.     ByVal lpCaption As LongPtr, ByVal wType As Long, _
  12.     ByVal wLange As Long, ByVal dwTimeout As Long) As Long
  13. #Else
  14.   Private Declare Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutW" ( _
  15.     ByVal hWnd As Long, ByVal lpText As Long, _
  16.     ByVal lpCaption As Long, ByVal wType As Long, _
  17.     ByVal wLange As Long, ByVal dwTimeout As Long) As Long
  18. #End If
  19. Private lngTimeOut As Long

  20. Public Property Let MsgboxTimeOutSecond(ByVal TimeOut As Long)
  21.   On Error GoTo LetSecondError
  22.   If TimeOut < 0 Then
  23.     lngTimeOut = 0
  24.   Else
  25.     lngTimeOut = TimeOut * 1000
  26.   End If
  27.   Exit Property
  28. LetSecondError:
  29.   lngTimeOut = &H7FFFFFFF
  30. End Property

  31. Public Property Let MsgboxTimeOut(ByVal TimeOut As Long)
  32.   If TimeOut < 0 Then
  33.     lngTimeOut = 0
  34.   Else
  35.     lngTimeOut = TimeOut
  36.   End If
  37. End Property

  38. Public Property Get MsgboxTimeOut() As Long
  39.   MsgboxTimeOut = lngTimeOut
  40. End Property

  41. Public Function Msgbox(ByVal Prompt As String, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
  42.                  Optional ByVal Title As String = vbNullString, Optional ByVal TimeOut As Long = -1&, _
  43.                  Optional ByVal LangeId As Long = 0&) As VbMsgBoxResult
  44.   'TimeOut以毫秒为单位,1 second = 1000 ms,TimeOut值为0时表示不自动返回,为负值时表示使用全局默认值
  45.   '如果信息框弹出后,用户未点击任何按钮,将返回3200,但如果Buttons的按钮值为VbOkOnly时,返回VbOk
  46.   
  47.   If TimeOut < 0 Then TimeOut = lngTimeOut
  48.   If Len(Title) < 1 Then Title = Application.Caption
  49.   Msgbox = MessageBoxTimeout(Application.hWnd, StrPtr(Prompt), StrPtr(Title), Buttons Or &H2000&, LangeId, TimeOut)
  50. End Function
复制代码


重要提示:由于已经出现三次“可爱人士”用QQ或是微信加我,询问要代码或是修改论坛共享代码,本人把代码免费发过去后,收到代码立马把我拉黑。故在此郑重声明:以后单独加我QQ或是微信要代码的,一律先收费后代码。百行以下收费人民币1000/次,百行以上每百行加1千。多谢合作,非诚勿扰。

我想来想去都想不明白,得到了免费帮助却要拉黑帮助人是什么心态?Jian
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 17:29 , Processed in 0.050428 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表