更改Outlook 2013電子郵件主題使用VBA

Question

我正在使用下面的代碼以文件夾中的標準文件命名格式保存多個選定的電子郵件，其路徑是從文本框（textbox1）中選擇的。根據是否選中複選框（複選框1），將確定運行代碼後是否刪除電子郵件。如果未選中該複選框，則電子郵件將保存到該文件夾​​中，但不會從Outlook中刪除。如果複選框未被選中，我希望Outlook中的電子郵件主題被更改，以便我知道我以前保存過電子郵件。下面的代碼幾乎做了我想要的一切，除了改變電子郵件主題。如果我只選擇一封電子郵件，則工作正常。但是，如果我選擇多個電子郵件，則只會更改第一封電子郵件的主題。任何幫助讚賞。

Sub SaveIncoming() 
Dim lngC As Long 
Dim msgItem As Outlook.MailItem 
Dim strPath As String 
Dim FiledSubject As String 

On Error Resume Next 
strPath = UserForm1.TextBox1.Value 
On Error GoTo 0 
If strPath = "" Then Exit Sub 
If Right(strPath, 1) <> "\" Then strPath = strPath & "\" 

If TypeName(Application.ActiveWindow) = "Explorer" Then 
' save selected messages in Explorer window 
If CBool(ActiveExplorer.Selection.Count) Then 
With ActiveExplorer 
For lngC = 1 To .Selection.Count 
If .Selection(lngC).Class = olMail Then 
MsgSaver3 strPath, .Selection(lngC) 

If UserForm1.CheckBox1.Value = True Then 

    .Selection(lngC).Delete 

    End If 

    If UserForm1.CheckBox1.Value = False Then 

FiledSubject = "[Filed" & " " & Date & "]" & " " & .Selection(lngC).Subject 

.Selection(lngC).Subject = FiledSubject 

End If 

End If 
Next lngC 
End With 
End If 
ElseIf Inspectors.Count Then 
' save active open message 
If ActiveInspector.CurrentItem.Class = olMail Then 
MsgSaver3 strPath, ActiveInspector.CurrentItem 
End If 
End If 
End Sub 

Private Sub MsgSaver3(strPath As String, msgItem As Outlook.MailItem) 
    Dim intC As Integer 
    Dim intD As Integer 
    Dim strMsgSubj As String 
    Dim strMsgFrom As String 
    strMsgSubj = msgItem.Subject 
    strMsgFrom = msgItem.SenderName 
    ' Clean out characters from Subject which are not permitted in a file name 
    For intC = 1 To Len(strMsgSubj) 
    If InStr(1, ":<>""", Mid(strMsgSubj, intC, 1)) > 0 Then 
    Mid(strMsgSubj, intC, 1) = "-" 
    End If 
    Next intC 
    For intC = 1 To Len(strMsgSubj) 
    If InStr(1, "\/|*?", Mid(strMsgSubj, intC, 1)) > 0 Then 
    Mid(strMsgSubj, intC, 1) = "_" 
    End If 
    Next intC 

    ' Clean out characters from Sender Name which are not permitted in a   file  name 
    For intD = 1 To Len(strMsgFrom) 
    If InStr(1, ":<>""", Mid(strMsgFrom, intD, 1)) > 0 Then 
    Mid(strMsgFrom, intD, 1) = "-" 
    End If 
    Next intD 
    For intD = 1 To Len(strMsgFrom) 
    If InStr(1, "\/|*?", Mid(strMsgFrom, intD, 1)) > 0 Then 
    Mid(strMsgFrom, intD, 1) = "_" 
    End If 
    Next intD 
    ' add date to file name 
    strMsgSubj = Format(msgItem.SentOn, "yyyy-mm-dd Hh.Nn.Ss") & " "   & "[From " & strMsgFrom & "]" & " " & strMsgSubj & ".msg" 
    msgItem.SaveAs strPath & strMsgSubj 
    Set msgItem = Nothing 
    UserForm1.Hide 
    End Sub 

Answer 1

當你刪除其餘的項目向上移動，從而2變爲1。你永遠不處理原始項目2

嘗試用

For lngC = .Selection.count to 1 step -1 

對於更換

For lngC = 1 To .Selection.count 

For Each循環在移動或刪除時不起作用。