Public Function MsgBoxEx(Prompt, Optional Buttons As VbMsgBoxStyle = 0, Optional Title, Optional TimeOut = 0) As VbMsgBoxResult
'---------------------------------------------------------------------------------------
' Procedure : MsgBoxEx
' Purpose   : MsgBox с таймаутом (используется метод Popup WScript.Shell)
'             Создаёт .VBS-файл во временной папке, запускает его, возвращает коды результата, удаляет временный файл
' Arguments : Первые 3 аргумента такие же, как у MsgBox, 4-й - таймаут в секундах.
'             Если 4-й аргумент не задан или <=0, то ожидает ввода пользователя как обычный MsgBox
' Ret.Value : Такие же, как у Msgbox, но возвращает -1 по истечении таймаута.
' Errors    : Возвращает ошибку 735 - "Can't save file to TEMP" если временная папка не доступна
' Author    : Казанский, [email]exceleved@yandex.ru[/email]
' URL       : http://www.cyberforum.ru/post5874942.html
' Date      : 09.03.2014
'---------------------------------------------------------------------------------------
   Dim sTmp$, ff%
   With CreateObject("WScript.Shell")
      sTmp = Environ("temp")
      If sTmp = "" Then
         sTmp = Environ("tmp")
         If sTmp = "" Then
            sTmp = .SpecialFolders("MyDocuments")
            If sTmp = "" Then Err.Raise 735, "MsgBoxEx", "Can't save file to TEMP"
         End If
      End If
      sTmp = sTmp & Format$(Now, """\~MsgBoxEx""YYYYMMDDHHMMSS"".vbs""")   'уникальное имя файла
      ff = FreeFile
      If IsMissing(Title) Then Title = ""
      Prompt = Str2Code(Prompt): TimeOut = Int(TimeOut): Title = Str2Code(Title): Buttons = Int(Buttons)
      Open sTmp For Output As ff
      Print #ff, "WScript.Quit CreateObject(""WScript.Shell"").Popup (""" & Prompt & """, " & TimeOut & ", """ & Title & """, " & Buttons & ")" ' Popup(<Text>,<SecondsToWait>,<Title>,<Type>) ' http://www.script-coding.com/WSH/WshShell.html#3.2.
      Close #ff
      MsgBoxEx = .Run(sTmp, 0, True) ' Run(<Command>,<WindowStyle>,<WaitOnReturn>) ' http://www.script-coding.com/WSH/WshShell.html#3.4.
   End With
   On Error Resume Next
   Kill sTmp
End Function
Private Function Str2Code$(sTxt) ' заменить CR+LF, LF+CR, CR, LF на " & vblf & " для использования в VBS
   Str2Code = Replace(Replace(Replace(Replace(Replace(sTxt, """", """"""), vbCrLf, vbLf), vbLf & vbCr, vbLf), vbCr, vbLf), vbLf, """ & vblf & """)
End Function