Outlook VBA 多附件电子邮件拆分为单个附件电子邮件

Question

我的目标：处理当前选定的邮件项目（活动资源管理器），我想创建与附件一样多的电子邮件副本，每个副本都有来自原始电子邮件的唯一附件。该电子邮件的接收日期（YYMMDD，例如 220219）和电子邮件包含的附件的文件名将成为其主题行，原始主题行添加到邮件正文的顶部。

原来的邮件可以删除，或者是上面操作过的邮件之一。

--

把它变成一个自我问答，我的答案在下面开放反馈或提出其他答案。

Answer 1

下面是我的尝试。请评论任何改进建议。

修订版 1：

Sub AttSplit()
  'declare variables
  Dim olMsg As MailItem, olNewMsg As MailItem, olAtt As Attachment
  Dim i As Integer, j As Integer, olAttachs As Integer, olRDate As Long
  'olMsg is set as the currently selected message in the reading pane
  Set olMsg = ActiveExplorer.Selection.Item(1)
  'then work out how many attachments there are in that email
  olAttachs = olMsg.Attachments.Count
  'and the received date of that email, converted to the date format I wanted
  olRDate = Format(olMsg.ReceivedTime, "yymmdd")
  'for each attachment (j)
  For j = olAttachs To 1 Step -1
    'create a copy of the original email in olNewMsg
    Set olNewMsg = olMsg.Copy
    'then loop through that copy's attachments
    For i = olAttachs To 1 Step -1
      'setting olAtt to which # attachment you are looking at
      Set olAtt = olNewMsg.Attachments(i)
      Select Case i
      'and where the attachment you created the copy of the email for (j)
      'is the attachment you are currently looking at in the copy
      Case j
        'manipulate the NewMsg body to include the original email subject
        olNewMsg.Body = "Original Email Subject: " & olMsg.Subject & vbLf & vbLf & olMsg.Body
        'and change the NewMsg subject to be the date and filename of the attachment
        olNewMsg.Subject = olRDate & " - " & olAtt.FileName
      Case Else
        'but if it isn't the attachment you created the copy of the email for
        'you delete that from the NewMsg
        olAtt.Delete
      End Select
    Next i
    'then save the current state of NewMsg with attachments being deleted etc
    olNewMsg.Save
  'and move onto the next j, which at the beginning of the loop sets olNewMsg to be
  'a copy of the original again
  Next j
  'and once done, delete the original email if no longer needed.
  olMsg.Delete
End Sub

原文：

Sub AttSplit()
  Dim olMsg As MailItem, olAttachs As Long, i As Long, olAtt As Attachment, olNewMsg As MailItem, j As Long, olRDate As Date, olRY As String, olRM As String, olRD As String
  Set olMsg = ActiveExplorer.Selection.Item(1)
  olAttachs = olMsg.Attachments.Count
  olRDate = olMsg.ReceivedTime
  olRY = Right(DatePart("yyyy", olRDate), 2)
  olRM = IIf(Len(DatePart("m", olRDate)) = 1, "0" & DatePart("m", olRDate), DatePart("m", olRDate))
  olRD = IIf(Len(DatePart("d", olRDate)) = 1, "0" & DatePart("d", olRDate), DatePart("d", olRDate))
  For j = olAttachs To 1 Step -1
    Set olNewMsg = olMsg.Copy
    For i = olAttachs To 1 Step -1
      Set olAtt = olNewMsg.Attachments(i)
      Select Case i
      Case j
        olNewMsg.Body = "Original Email Subject: " & olMsg.Subject & vbLf & vbLf & olMsg.Body
        olNewMsg.Subject = olRY & olRM & olRD & " - " & olAtt.FileName
      Case Else
        olAtt.Delete
      End Select
    Next i
    olNewMsg.Save
    Set olNewMsg = Application.CreateItem(olMailItem)
  Next j
  olMsg.Delete
End Sub

Outlook VBA 多附件电子邮件拆分为单个附件电子邮件

Outlook VBA multi-attachment email split into single attachment emails

outlook

vba