使用 VBA 更改 Outlook 2013 电子邮件主题

Question

I am using the code below to save multiple selected emails in a standard file naming format in a folder, who's path is selected from a text box (textbox1). Depending on whether a checkbox (checkbox1) is selected or not will determine whether the emails are deleted after running the code. If the the checkbox is not selected then the emails are saved to the folder but not deleted from Outlook. If the checkbox is not selected then I want the email subject in Outlook to be changed in order that I know that I have previously saved the email. The code below pretty much does everything I want except changing the email subject. If I select only one email all works fine. However if I select more than one email then only the subject of the first email gets changed. Any help appreciated.

 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

When you delete the remaining items move up so 2 becomes 1. You never process the original item 2.

Try replacing

For lngC = 1 To .Selection.count

with

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

For the same reason a For Each loop does not work when moving or deleting.