0

こんにちは、みんな、

メールアイテムをフォルダーに保存するコードを作成しました。

問題を除いて、それは完全にうまく機能していました.数回、Outlookが応答せず、タスクを終了して閉じる必要がありました.

最初は、ファイルサイズのせいだと思っていました。その後、この問題は 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
4

1 に答える 1

1

まず、同じ条件の If ステートメントが 5 つある理由がわかりません。それらを1つに丸めませんか？

第二に、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
于 2014-11-14T18:00:13.383 に答える