Outlook VBA - Msg.SaveAs“路径”问题

Question

大家好，

我编写了一个代码，将邮件项保存在文件夹中。

它运行良好，除了一个问题：有几次，Outlook 没有响应，我不得不通过 Ending Task 关闭它。

起初，我以为是文件大小的原因。 然后，我发现这个问题是由于 MailItem 的长度。 当消息太长时，Outlook 开始没有响应，我必须关闭它。

有人可以帮我吗？

代码是：

Private Sub CommandButton3_Click()

Unload Me

Dim Path As String
Dim Mes As String
Dim Hoje As String
Dim Usuario As String
Dim Diretorio As String
Dim olApp As Object
Dim olNs As Object



'Path do servidor
Path = "\\Brsplndowd009\DMS_BPSC_LAA\Customer_Service\Unapproved\Samples\Sample Orders - 2014"
'Mes
Mes = Mid(Date, 4, 2)
'Data
Hoje = Left(Date, 2) & UCase(Left(MonthName(Mes), 3)) & Right(Date, 2)
'Usuário
    Usuario = "LEVY"


'1. Nome da Pasta

Diretorio = Path & "\" & Source & "\" & Tracking & " - " & Customer & " - " & Material & " - " & Hoje & " - " & Usuario


'Dim Msg As Outlook.MailItem'
Dim Msg As Object
Dim Att As Outlook.Attachment
Dim olConc As Outlook.Folder
Dim olConc2 As Outlook.Folder
Dim olItms As Outlook.Items


'Get Outlook
Set olApp = GetObject(, "Outlook.application")
Set olNs = olApp.GetNamespace("MAPI")
Set olItms = GetFolder("Caixa de correio - FLHSMPL\Inbox\00-Levy").Items
Set olConc2 = GetFolder("Caixa de correio - FLHSMPL\Inbox\00-Levy")
Set olConc = GetFolder("Caixa de correio - FLHSMPL\Inbox\00-Levy\Encerrar")


'Loop

    For Each Msg In olItms

    If InStr(1, Msg.Subject, Tracking) > 0 Then MkDir Diretorio
    If InStr(1, Msg.Subject, Tracking) > 0 Then Msg.Move olConc
    If InStr(1, Msg.Subject, Tracking) > 0 Then Msg.SaveAs Diretorio & "\" & "Caso" & " " & Tracking & ".msg"

    If InStr(1, Msg.Subject, Tracking) > 0 Then Success.Show
    If InStr(1, Msg.Subject, Tracking) > 0 Then Exit Sub


   Next Msg


Fail.Show

End Sub

Answer 1

首先我不确定为什么你有 5 个条件相同的 If 语句。不把它们合二为一吗？

其次，您正在调用 Move，然后尝试向我们发送原始消息。你不能那样做 - 旧物品不见了。您需要使用 Move 重新生成的新的：

If InStr(1, Msg.Subject, Tracking) > 0 Then 
  MkDir Diretorio
  set Msg = Msg.Move(olConc)
  Msg.SaveAs Diretorio & "\" & "Caso" & " " & Tracking & ".msg"
  Success.Show
  Exit Sub
End If