CODEWITHSUNDEEP
vbaoutlook
Digital Lightcraft
Digital Lightcraft

Reputation: 465

How do I get Outlook to periodically check a folder for files then email them out?

Here is the proposed situation that I've been tasked with making work:

OK so I'm fine up to the last point:

I will use a small VBA script in an instance of Outlook on a sever to pull out the thing.foo file, give it a unique file name (uniqueThing.foo), and drop it in the network folder. The process (which is nothing to do with me) will run its course and save out as something like "uniqueThing_processed.foo" (maybe move the original to an archive folder)... I'm ok to this point.

Now, what I need to do is to get this instance of Outlook to check periodically (say every 5 minutes) for a "********_processed.foo" file, attach that to an email and send it (then maybe move the file to the archive and append "_sent")

Upvotes: 0

Views: 755

Answers (1)

Dan H.
Dan H.

Reputation: 149

As Alex K. stated, use a timer: Add to "ThisOutlookSession" the folowing

Private Sub Application_Quit()
If TimerID <> 0 Then Call EndTimer 'Turn off timer upon quitting **VERY IMPORTANT**
End Sub

Private Sub Application_Startup()
'MsgBox "Activating the Timer."
Call StartTimer 'Set timer to go off every 1 minute
End Sub

in a Module add the following:

Public Declare Function SetTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

Public Declare Function KillTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long, TimerSeconds As Single, tim As Boolean
Dim Counter As Long
Sub LookForNew()
  Dim mess_body As String, StrFile As String, StrPath As String
  Dim appOutLook As Outlook.Application
  Dim MailOutLook As Outlook.MailItem

  Set appOutLook = CreateObject("Outlook.Application")
  Set MailOutLook = appOutLook.CreateItem(olMailItem)
  Dim n As String, msg As String, d As Date
  msg = ""
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set fils = fso.GetFolder("<<<Put your folder here>>>").Files
  For Each fil In fils
    n = fil.Name
    d = fil.DateCreated
    If d >= Date - 1 Then
      msg = msg & n & vbTab & d & vbCrLf
    End If
  Next fil
  If msg <> "" Then
    StrPath = "<<<Put your folder here>>>\" 'attention to the extra "\"
      With MailOutLook
       .BodyFormat = olFormatRichText
       .To = "<<<Put your Mail-Adress here>>>"
       .Subject = "Scan"
       .HTMLBody = msg
       StrFile = Dir(StrPath & "*.*") '~~> *.* for all files
       Do While Len(StrFile) > 0 'loop through all files in the Folder
       .Attachments.Add StrPath & StrFile
       StrFile = Dir
       Loop
       .DeleteAfterSubmit = True 'delete Mail from Send Items
       .Send
      End With
    Kill StrPath & "*.*" 'delete all files from Folder
  End If
  Set fso = Nothing
End Sub

Sub StartTimer()'~~> Start Timer
'~~ Set the timer for 60 second
TimerSeconds = 60
TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc)
End Sub

Sub EndTimer()'~~> End Timer
On Error Resume Next
KillTimer 0&, TimerID
End Sub

Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, _
ByVal nIDEvent As Long, ByVal dwTimer As Long)
Call LookForNew ' call your existing or modified code here
End Sub

Upvotes: 1

Related Questions