I have created this script to play a wav file when I receive an email. The point is to play the sound only during business hours. If the email is received outside business hours, no sound will play.
Private Declare PtrSafe Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long
Sub PlayWavFile(WavFileName As String, Wait As Boolean)
If Dir(WavFileName) = "" Then Exit Sub ' no file to play
If Wait Then ' play sound synchronously
PlaySound WavFileName, 0, 0
Else ' play sound asynchronously
PlaySound WavFileName, 0, 1
End If
End Sub
Sub PlayASoundDuringBusinessHours(Item As Outlook.MailItem)
Dim SecondsSinceMidnight
Dim SecondsPerHour
Dim NineOclockAm
Dim NineOclockPm
Dim TooEarly
Dim TooLate
On Error GoTo ErrHandler:
SecondsSinceMidnight = Timer
SecondsPerHour = 60 * 60
NineOclockAm = SecondsPerHour * 9
NineOclockPm = SecondsPerHour * 21
TooEarly = Timer < NineOclockAm
TooLate = Timer > NineOclockPm
If Not (TooEarly) And Not (TooLate) Then
PlayWavFile "c:\windows\media\blahblahblah.wav", False
End If
ExitProcedure:
Exit Sub
ErrHandler:
MsgBox Err.Description, _
vbExclamation + vbOKCancel, _
"Error: " & CStr(Err.Number)
Resume ExitProcedure:
End Sub
I have a rule in Outlook that uses this script when mail comes in and it works! For a while, anyway.
I do not know what the problem is, but once in a while an error occurs in this script and I get a dialog from Outlook that says "Rules in error" and "The operation failed." When this happens, the Outlook rule that uses this script becomes disabled.
Is my exception handling inadequate? What could be causing this error and how do I handle it properly?
Update:
The rule is very basic. It does little beyond executing the script:
Apply this rule after the message arrives
on this computer only
run Project.PlayASoundDuringBusinessHours
Not a direct response to the question but my solution was to switch to ItemAdd.
Examples:
http://msdn.microsoft.com/en-us/library/office/aa171270(v=office.11).aspx
http://www.outlookcode.com/article.aspx?id=62
Related
I am working on a VBA Module for an interactive PowerPoint. Specifically, I would like a text box to display the current time and update every second (like a live clock) using VBA. I have created and implemented the clock just fine except the clock does not exit its loop when the presentation ends and will continue to update the text box while editing the PowerPoint outside of the presentation mode. I have tried using the sub App_SlideShowEnd(ByVal Pres As Presentation) ( https://learn.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshowend), sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow) (https://learn.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshownextslide), and even an add-in called AutoEvents (usage shown here http://www.mvps.org/skp/autoevents.htm#Use) to catch the end of the slide show, but to no avail.
So my question to you is: Is there a way to check if the current PowerPoint is actively presenting? If so, I could use it to check if the PowerPoint is presenting instead of checking my boolean variable clockstate that allows the clock to count or not. Here is the implementation of just the clock sub:
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Here is the implementation of just the App_SlideShowEnd event:
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
And here is all of my code all together if you want to see it in one piece:
Option Explicit
Dim indexA As Integer 'this variable contains the slide that Injury_Time is found on for use in the auto next slide event
Dim indexB As Integer 'this varaible contains the slide that Defect_Time is found on for use in the auto next slide event
Dim clockstate As Boolean 'this varaible dictates wether or not the clock is on and counting to save memory/processing resources.
Dim Injury As Shape 'this variable is used to reference the textbox that gets changed by the macro
Dim Defect As Shape 'this varaible is used to reference the other textbox that gets changed by the macro
Dim entryA As Date 'this holds the contents of the first entrybox on the config form so the form can be unloaded without losing the entries
Dim entryB As Date 'this holds the contents of the second entrybox on the config form so the form can be unloaded without losing the entries
Dim daysA As String 'this holds the number of days since last injury for auto-setting the textboxes in the config form
Dim daysB As String 'this holds the number of days since last defect for auto-setting the textboxes in the config form
Sub Auto_Open() 'runs on startup from AutoEvents add-in. runs the find function to locate the Macro-edited slides, then opens the config form
'declare clockstate as false until it is true and turned on
clockstate = False
'assign values the global Injury and Defect variables
Call Find
'try calling the name fields (need to assign it to a variable to try it). If Injury and Defect were found, then nothing happens. Otherwise it moves the the Not_Found label
On Error GoTo Not_Found
'setup daysA and daysB
daysA = Left(Injury.TextFrame.TextRange.text, Len(Injury.TextFrame.TextRange.text) - 8)
daysB = Left(Defect.TextFrame.TextRange.text, Len(Defect.TextFrame.TextRange.text) - 8)
'assign default values to the Config boxes
Config.TextBox1.Value = Date - daysA
Config.TextBox2.Value = Date - daysB
'show config
Config.Show
Exit Sub
'error messaging for if the textbox assignments were not found
Not_Found:
MsgBox "Error: The Macro-edited textbox(es) were not found! This is likely due to the most recent editing preformed on this Powerpoint. Please revert the changes, create a new textbox with the name """"Injury_Time"""" or """"Defect_time"""" (whichever is missing), contact your local VBA expert, or read the Documentation for help."
End Sub
Sub Find() 'locates the textbox that the global variables Injury and Defect are supposed to represent
'use a 2D for loop to iterate through each slide and it's shapes
Dim i As Integer
Dim j As Integer
For i = 1 To ActivePresentation.Slides.Count
For j = 1 To ActivePresentation.Slides(i).Shapes.Count
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Injury_Time") = 0 Then
Set Injury = ActivePresentation.Slides(i).Shapes(j)
indexA = i
End If
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Defect_Time") = 0 Then
Set Defect = ActivePresentation.Slides(i).Shapes(j)
indexB = i
End If
Next j
Next i
End Sub
Sub Save() 'saves the contents of the config form to the global varaibles entryA and entry B then unloads the form to save memory
'save the contents of the config form so we can unload it to save memory
entryA = Config.TextBox1.Value
entryB = Config.TextBox2.Value
'unload the form to save memory
Unload Config
End Sub
Sub Auto_ShowBegin() 'starts the clock for the timers when the show starts
'start clock
clockstate = True
Call clock
End Sub
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
Sub Auto_Close() 'this is run by the AutoEvents add-in. It displays an informative message when the powerpoint is closed with instructions for the next time the powerpoint is opened
'prevent clock from running after program is closed
clockstate = False
'message to configure the powerpoint when it is opened again
MsgBox "Thank you for using this Macro-Enabled PowerPoint!" & vbCrLf & vbCrLf & "Next time the PowerPoint is opened, you will be asked to re-enter the dates of the most recent injury and quality defect."
End Sub
Thank you for your help and May the 4th be with you!
I think your 'Wait' function is not reliable. The 'for' loop may not end in some case.
To control the clock ticking event, you can make use of Windows 'Timer' API. Though the Timer API is not that reliable or easy to use, it can be controlled and tailored.
The sample code goes like this:
Option Explicit
#If VBA7 Then
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Public TimerID As LongPtr
#Else
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long
#End If
Const Default As Integer = 1 'the target slide where the 'Clock' textbox exists
Dim Pause As Boolean
Sub StartNow()
StartTimer
End Sub
Sub StopNow()
StopTimer
End Sub
'main timer process : this sub-routine CANNOT be interrupted by any error or itself
Sub myTimer()
On Error Resume Next
If Pause Then Exit Sub
'the Default slide should have a textbox called 'Clock'
ActivePresentation.Slides(Default). _
Shapes("Clock").TextFrame.TextRange.Text = Format(Time, "hh:mm:ss")
End Sub
Function StartTimer()
If TimerID = 0& Then
TimerID = SetTimer(0&, 0&, 1000&, AddressOf myTimer) ' 1000 = 1sec
End If
End Function
Function StopTimer()
On Error Resume Next
KillTimer 0&, TimerID
TimerID = 0&
End Function
'the timer can be paused, if this macro is added to the 'Clock' textbox as an action trigger
Sub PauseTimer()
Pause = Not Pause
End Sub
'the timer must be stopped after finishing the show
Public Sub OnSlideShowTerminate(SSW As SlideShowWindow)
StopTimer
End Sub
'To start the clock automactically
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
If SSW.View.CurrentShowPosition = Default Then
StartTimer
Else
StopTimer
End If
End Sub
Requirement: A Textbox called 'Clock' should exist on Slide #1.
Warning:
The Timer must be stopped after closing the show. Otherwise, Powerpoint application might crash!
'myTimer' should not contain any error or call itself recursively.
I am trying to download file using InternetExplorer.Application, but it always opens a window asking to save or open the file. Is there a way to circumvent this and have it run and save in the background? Here is a block of code I have tried.
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "https://pastebin.com/raw/terAweb"
State = 0
Do Until State = 4
DoEvents
State = ie.readyState
Loop
Dim file: file= ie.Document.Body.innerHTML
Using the URL Monikers API instead of trying to communicate with the InternetExplorer Application might be simpler.
Was that specifically done for Pastebin? Because it doesn’t really work with it, as far as I know. But I guess you can use another one 😉
Option Explicit
Private Declare PtrSafe Function URLDownloadToFileA Lib "URLMON" _
(ByVal pcaller As Long, _
ByVal szurl As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As LongPtr
Sub Example()
Dim Download$
On Error GoTo ErrorHandler
Download = URLDownloadToFileA(0, "myURL", "C:\Users\Name\Downloads\test.txt", 0, 0)
Exit Sub
ErrorHandler:
MsgBox Err.Number & " " & Err.Description
End Sub
Please refer to the following sample code, after using the getElementbyId method to find the download button, it will display the download prompt, we could using the Application.SendKeys "%{s}" command to click the Save button.
Sub downloadfile()
Dim IE As Object, Data As Object
Dim ticket As String
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = True
.navigate ("https://dillion132.github.io/default.html")
While IE.ReadyState <> 4
DoEvents
Wend
'Trigger the download button to download the file
IE.Document.getElementbyId("btnDowloadReport").Click
'wait the download prompt appear
Application.Wait (Now + TimeValue("00:00:03"))
'
Application.SendKeys "%{s}"
'Waiting for the site to load.
'loadingSite
End With
Set IE = Nothing
End Sub
The web page content:
<a id="btnDowloadReport" href="https://research.google.com/pubs/archive/44678.pdf" download>Download</a>
A week ago I had a presentation where I was making an AI using Voice Recognition with VBA. It worked perfectly (I took the code from this WebSite) till some day I was going to test it again and it didn't work. It returns an error
"Run-time error '70': Permission denied"
I checked my microphone and the VBA References needed that are mentioned in the WebSite. Then I went to the Site I took the code from and I saw a different version of the code (Public, Shared...) and when I ran it, another error appears
"Run-time error '-2147200905 (80045077)': Automation error"
So can someone please help me, the code used to work and I didn't change anything. Here's the code:
Option Explicit
Dim WithEvents RC As SpInProcRecoContext
Dim Recognizer As SpInprocRecognizer
Dim myGrammar As ISpeechRecoGrammar
Private Sub CommandButton1_Click()
'On Error GoTo EH
Set RC = New SpInProcRecoContext
Set Recognizer = RC.Recognizer
Set myGrammar = RC.CreateGrammar
myGrammar.DictationSetState SGDSActive
Dim Category As SpObjectTokenCategory
Set Category = New SpObjectTokenCategory
Category.SetId SpeechCategoryAudioIn
Dim Token As SpObjectToken
Set Token = New SpObjectToken
Token.SetId Category.Default()
Set Recognizer.AudioInput = Token
'EH:
' If Err.Number Then ShowErrMsg
End Sub
Private Sub RC_Recognition(ByVal StreamNumber As Long, ByVal StreamPosition As Variant, ByVal RecognitionType As SpeechLib.SpeechRecognitionType, ByVal Result As SpeechLib.ISpeechRecoResult)
On Error GoTo EH
TextBox1.text = Result.PhraseInfo.GetText
EH:
If Err.Number Then ShowErrMsg
End Sub
Private Sub ShowErrMsg()
' Declare identifiers:
Const NL = vbNewLine
Dim T As String
T = "Desc: " & Err.Description & NL
T = T & "Err #: " & Err.Number
MsgBox T, vbExclamation, "Run-Time Error"
'End
End Sub
'### Second version of the code (Shared, Public...)
Option Explicit
Public WithEvents RC As SpSharedRecoContext
Public myGrammar As ISpeechRecoGrammar
Private Sub CommandButton1_Click()
'On Error GoTo EH
Set RC = New SpSharedRecoContext
Set myGrammar = RC.CreateGrammar
myGrammar.DictationSetState SGDSActive
'EH:
'If Err.Number Then ShowErrMsg
End Sub
Private Sub RC_Recognition(ByVal StreamNumber As Long, ByVal StreamPosition As Variant, ByVal RecognitionType As SpeechLib.SpeechRecognitionType, ByVal Result As SpeechLib.ISpeechRecoResult)
Label1.Caption = Result.PhraseInfo.GetText
End Sub
Private Sub RC_StartStream(ByVal StreamNumber As Long, ByVal StreamPosition As Variant)
'Label2.Caption = Val(StreamNumber)
End Sub
Private Sub ShowErrMsg()
' Declare identifiers:
Const NL = vbNewLine
Dim T As String
T = "Desc: " & Err.Description & NL
T = T & "Err #: " & Err.Number
MsgBox T, vbExclamation, "Run-Time Error"
End
End Sub
That error is saying:
SPERR_RECOGNIZER_NOT_FOUND 0x80045077 -2147200905
No recognizer is installed.
I have a master macro in an Excel file, 'file A' that opens another Excel file, 'file B'. On open, an add-in imports data into 'file B'. I would like to close 'file B' once the add-in is finished importing, and I'm looking for the best way to do that.
I've written the code to open 'file B' (which triggers the add-in automatically) and to close the file, but when the add-in is finished, it opens a MsgBox to notify the user. I'm trying to completely automate an internal process, so dismissing the MsgBox programmatically would be ideal.
Is it possible to dismiss a MsgBox through VBA? I'm aware that I can create timed MsgBoxes in VBA but I'm not creating this MsgBox (the add-in is); I just want to dismiss it. I'm open to creating a Word file and calling a macro from that if required, but would prefer not to use SendKeys.
Since the "add-in" and Excel/VBA run in the same context, we cannot launch it and monitor its message-box within the same VBA application, because each VBA application is a single-threaded process. Fortunately however, there is a solution that can exploit the fact that different VBA applications run in different contexts, so they can run in parallel.
My suggested solution is to create a MS-Word document that is dedicated to monitoring and closing that message box. We need this in Word (or any other office application) in order to make the monitoring code and the addin's code run in parallel, in different contexts.
1- create a Word macro-enable document, named mboxKiller.docm and place it in some folder; i.e. C:\SO in my example. place this code in ThisDocument and save:
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Sub WaitAndKillWindow()
On Error Resume Next
Dim h As Long: h = FindWindow(vbNullString, "Microsoft Excel")
If h <> 0 Then SendMessage h, 16, 0, 0 ' <-- WM_Close
Application.OnTime Now + TimeSerial(0, 0, 1), "WaitAndKillWindow"
End Sub
Private Sub Document_Open()
WaitAndKillWindow
End Sub
2- In the Excel workbook's VBA, create a class module, named mboxKiller with this code:
Private killerDoc As Object
Private Sub Class_Initialize()
On Error Resume Next
Set killerDoc = CreateObject("Word.Application").Documents.Open(Filename:="C:\SO\mboxKiller.docm", ReadOnly:=True)
If Err.Number <> 0 Then
If Not killerDoc Is Nothing Then killerDoc.Close False
Set killerDoc = Nothing
MsgBox "could not lauch The mboxKiller killer. The message-box shall be closed manuallt by the user."
End If
End Sub
Private Sub Class_Terminate()
On Error Resume Next
If Not killerDoc Is Nothing Then killerDoc.Application.Quit False
End Sub
3- Testing and Usage. In a normal class Module, place the following code and test the procedure
Sub Test() ' <-- run this for testing after finishing the setup
Dim killer: Set killer = New mboxKiller
simulateAddin
simulateAddin
simulateAddin
End Sub
' Procedure supposed to do some calculation then display a message box
Private Sub simulateAddin()
Dim i As Long
For i = 0 To 1000: DoEvents: Next ' simulates some calculations
MsgBox "This is a message box to simulate the message box of the addin." & VbCrLf & _
"It will be automatically closed by the Word app mboxKiller"
End Sub
VBA also has the ability to temporarily dismiss alerts.
Application.DisplayAlerts = False
'while you run your code here, no alerts will be displayed
Application.DisplayAlerts = True
Is there any type of msgbox in vb.net that gives a message and it disappears automatically after a certain time?
Or is there any method to hide the msgbox, without user's clicking OK?
You Can use
CreateObject("WScript.Shell").Popup("Welcome", 1, "Title")
this msgbox will close automatically after 1 second
No, I don't think there's a built-in framework control that will do this for you. However, you could easily do this with a custom-built form that fires a timer in it's Load event. Then, when the set amount of time has passed, in the timer Elapsed event, you can simply close the form.
Linendra Soni's answer is good, but it may or may not work in the newer versions of Windows and/or Excel.
This works perfectly in the newer versions:
Function MessageTimeOut(sMessage As String, sTitle As String, iSeconds As Integer) As Boolean
Dim Shell
Set Shell = CreateObject("WScript.Shell")
Shell.Run "mshta.exe vbscript:close(CreateObject(""WScript.shell"").Popup(""" & sMessage & """," & iSeconds & ",""" & sTitle & """))"
MessageTimeOut = True
End Function
Use it like this:
Sub Example()
Dim chk As Boolean
chk = MessageTimeOut("Hello!", "Example Sub", 1) 'if chk returned FALSE that means the function was not executed successfully
End Sub
or
Sub Example()
Call MessageTimeOut("Hello!", "Example Sub", 1) 'you don't need to get the output of the function
End Sub
Output:
Use a timer or some type of delay/sleep and after time expires run
SendKeys.Send("~")
This is the same has hitting the ENTER key.
You may need to make it proceed it by activating the msgbox window again.
Inspired by the answers, this is what I came with, working nicely in simple cases, allowing to use all MsgBox features directly:
Imports System.Threading
Module FormUtils
Private sAutoClosed As Boolean
Private Sub CloseMsgBoxDelay(ByVal data As Object)
System.Threading.Thread.Sleep(CInt(data))
SendKeys.SendWait("~")
sAutoClosed = True
End Sub
Public Function MsgBoxDelayClose(prompt As Object, ByVal delay As Integer, Optional delayedResult As MsgBoxResult = MsgBoxResult.Ok, Optional buttons As MsgBoxStyle = MsgBoxStyle.ApplicationModal, Optional title As Object = Nothing) As MsgBoxResult
Dim t As Thread
If delay > 0 Then
sAutoClosed = False
t = New Thread(AddressOf CloseMsgBoxDelay)
t.Start(delay)
MsgBoxDelayClose = MsgBox(prompt, buttons, title)
If sAutoClosed Then
MsgBoxDelayClose = delayedResult
Else
t.Abort()
End If
Else
MsgBoxDelayClose = MsgBox(prompt, buttons, title)
End If
End Function
End Module
PS: You must add this to yourApp.config file:
<appSettings>
<add key="SendKeys" value="SendInput"/>
</appSettings>
I dont think there is a tool such as that. But I think you can do that with follow this steps;
Create an instance of Form element, and design it like a messagebox.
In Form load event, get the system time or start the timer with interval value.
This timer tick how many seconds you want then call the Form Close event.
P.S : If I'm wrong, I'm sorry. I only try to solve something, maybe there is a better way to solve your problem.
You can do this by adding a Timer to your form.
'Timer to autoclose after 100 ms
Dim seconds As Integer = 100
'Existing code....
Timer1.Start()
MessageBox.Show("Window Timed Out", "TimeOut")
Me.Close()
'Tick Event Code
Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles Timer1.Tick
seconds = seconds - 1
If seconds < 1 Then`
Me.Close()
End If
End Sub
I have some code to show file updated time and close message box within 3 sec.
Please see below.
I hope that this code can support this topic.
Sub Workbook_Open()
Application.ScreenUpdating = False
SplashUserForm.Show
Windows(ThisWorkbook.Name).Visible = True
Application.ScreenUpdating = True
last_update = "Last updated : " & Format(FileDateTime(ThisWorkbook.FullName), "ddd dd/mm/yy hh:mm ampm")
'Close message after time if no action!
Dim myTimedBox As Object
Dim boxTime%, myExpired%, myOK%, myQuestBox%
'Access timed message box.
Set myTimedBox = CreateObject("WScript.Shell")
boxTime = 3
'User Selected "OK."
If myQuestBox = 1 Then
'Add any code in place of code below for this condition!
myOK = myTimedBox.Popup(last_update & vbCr & "Do nothing and this message will close in 3 seconds.", _
boxTime, "You Took Action!", vbOKOnly)
Else
'User took no Action!
myExpired = myTimedBox.Popup(last_update & vbCr & "Do nothing and this message will close in 3 seconds.", _
boxTime, "No Action Taken!", vbOKOnly)
End If
End Sub
This is the way
http://www.vbforums.com/showpost.php?p=3745046&postcount=5