Loop through attachments

[Excelmasters]

Hello,

i have my below code sends email on birthday for multiple users. and attaches a image (greeting) on body of the email.

and its loop .. can anyone suggest me that how to loop the attachments as per the user . currently its adding only one attachments for all the emails.

Sub DoBirthdayRoutine()

Dim olApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Msg As String
Dim EmailAddr2 As String
Set olApp = New Outlook.Application
Application.ScreenUpdating = False
Sheets("Sheet1").Activate
LR = Range("B" & Rows.Count).End(xlUp).Row


 For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr2 = EmailAddr2 & ";" & cell.Value
End If
Next


For Each cell In Range("B2:B" & LR)
    If Month(cell) = Month(Date) And Day(cell) = Day(Date) Then
    Pos = WorksheetFunction.Find(" ", cell.Offset(, -1))
    FName = Left(cell.Offset(, -1), Pos - 1)
    Subj = "Happy B'day"
    EmailAddr = cell.Offset(, 1).Value
    Msg = "Dear " & FName & "," & vbNewLine
Msg = Msg & vbNewLine & " Happy Birthday to you and many more happy returns. Have a wonderful day." & vbCrLf & vbCrLf








Set MItem = olApp.CreateItem(olMailItem)
With MItem
    .To = EmailAddr
    .Subject = Subj
    .Body = Msg
    .bcc = EmailAddr2
    .Attachments.Add "D:\my documents\mypic.jpg", , 0


.HTMLBody = .HTMLBody & "<img src='cid:mypic.jpg'" & "width='1141' height='747'><br>"
             
    
    .Display
    
End With
End If
Next


Application.ScreenUpdating = True


End Sub