Outlook VBA multi-attachment email split into single attachment emails

Question

My aim: Working on the currently selected mail item (active explorer), I would like to create as many copies of that email as there are attachments, with each of them having a unique attachment from the original email. The date of receival of that email (YYMMDD eg 220219) and file name of the attachment that email contains would become it's subject line, with the original subject line added to the top of the message body.

The original email can be deleted, or be one of the emails manipulated in the above.

--

Turning this into a self-Q&A, with my answer below open to feedback or to have other answers proposed.

Answer 1

My attempt below. Please comment any improvement suggestions.

Revision 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

Original:

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