Outlook VBA - Msg.SaveAs "Path" issue

Question

Hi all,

I have written a code that saves a mailitem in a folder.

It was working perfectly well, except for an issue: a few times, Outlook did not respond and I had to close it by Ending Task.

At first, I thought it was because of the file size. Then, I found out that this issue was due to the length of the MailItem. When the message is too long, Outlook starts not responding and I have to close it.

Can someone help me?

Code is:

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

Firstly I ma not sure why you have 5 If statements with the same condition. Wjy not roll them into one?

Secondly, You are calling Move, then try to us the original message. You cannot do that - the old item is gone. You need to use the new one retruned by 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