Outlook rule does not always work
Posted on 2013-01-05
I made a code for Outlook 2010 with an Exchange Server at work. I put the script in ThisOutlookSession.
The rule do the following:
Check incoming mail, from address1 or address2, with the words 'word1' or 'word2' in the topic or text, with an attachment, only at this computer, move the email to a subfolder, run script Projekt1.ThisOutlookSession.SaveAllAttachments and mark it as read.
The code save the attachment as a picture, with the name depending on which time it arrive to Outlook. Then it is printed with irfanview.
The code is here below.
The rule and code works fine most of the time, but sometimes it fails. This happen mostly in the middle of the night, so it is hard to know what happen. When it fails it becomes deactivated.
What can be wrong?
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub SaveAllAttachments(objitem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
strLocation = "N:\KARTOR\ANALYS\" ' Ändra till analyskartorkatalogen
On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
For dblLoop = 1 To dblCount
' strID = Format(Time, "hh") 'Get the current Time in hours
strID = Format(objitem.SentOn, "hh") 'Get the time the mail was sent on
'strID = strID & " at " & Format(Time, "hh`mm AMPM") 'Append the Time
If strID > 0 And strID <= 6 Then
filnamn = "00"
If strID > 6 And strID <= 12 Then
filnamn = "06"
If strID > 12 And strID <= 18 Then
filnamn = "12"
If strID > 18 Or strID = 0 Then
filnamn = "18"
strName = objAttachments.Item(dblLoop).FileName 'Get attachment name
strExt = Right$(strName, 4) 'Store file Extension
strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
' strName = strName & strID & strExt 'Reattach Extension
' Tell the script where to save it and
' what to call it
strName = strLocation & filnamn & ".jpg" 'Put it all together
' Save the attachment as a file.
strCommand = "C:\program files\irfanview\i_view32.exe " & strName & " /print=\\lpcluster4\printer-st1"
Dim myApp As Double
myApp = Shell(strCommand, vbHide)
Set objAttachments = Nothing
Set objOutlook = Nothing