Изменение темы электронной почты Outlook 2013 с использованием VBA

Question

Я использую следующий код, чтобы сохранить несколько выбранных писем в стандартном формате имен файлов в папке, путь которого выбран из текстового поля (текстовое поле 1). В зависимости от того, выбран флажок (checkbox1) или нет, будет определяться, удаляются ли электронные письма после запуска кода. Если флажок не выбран, электронные письма сохраняются в папке, но не удаляются из 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 = 1 To .Selection.count 

с

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

Для по той же причине, что для каждого цикла не работает при перемещении или удалении.