如何让 Outlook 定期检查文件夹中的文件，然后通过电子邮件将它们发送出去？

Question

这是我被要求完成工作的建议情况：

• 监控电子邮件收件箱
• 将收到一封带有附件“thing.foo”的电子邮件
• 我们希望能够剥离附件并保存到网络上的文件夹中
• 这将通过监控文件夹的系统自动处理
• 然后我们希望能够提取一个输出文件并将其返回给 .foo 来自的原始电子邮件的发件人（假设这始终是相同的地址并且已修复）

好的，到最后一点我都很好：

我将在服务器上的 Outlook 实例中使用一个小的 VBA 脚本来提取 thing.foo 文件，为其指定一个唯一的文件名 (uniqueThing.foo)，然后将其放入网络文件夹中。 该过程（与我无关）将运行并保存为“uniqueThing_processed.foo”之类的内容（可能将原始文件移动到存档文件夹）......我没问题。

现在，我需要让这个 Outlook 实例定期（比如每 5 分钟）检查“********_processed.foo”文件，并将其附加到通过电子邮件发送（然后可能将文件移动到存档并附加“_sent”）

Answer 1

正如 Alex K. 所说，使用计时器： 将以下内容添加到“ThisOutlookSession”

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

在模块中添加以下内容：

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