บันทึกอีเมลรายวันรวมไว้หากชื่อไฟล์ซ้ำกัน

ฉันกำลังเขียนแมโครที่จะบันทึกอีเมลทุกวัน ฉันแค่คิดถึงสถานการณ์ที่อาจเกิดขึ้นได้ บางครั้งฉันได้รับอีเมลที่มีหัวเรื่องเดียวกันจากผู้ส่ง แต่อีเมลแต่ละฉบับมีเนื้อหาที่แตกต่างกัน ฉันต้องการชุดคำสั่งที่จะจัดการเรื่องนี้ อาจบอกว่าเป็นสำเนาหรืออาจต่อท้ายชื่อไฟล์ด้วย นี่คือรหัสที่ฉันมีตอนนี้

Public Sub SaveMsgs(Item As Outlook.MailItem)
 Dim sPath As String
 Dim dtDate As Date
 Dim sName As String
 Dim enviro As String
 Dim sSender As String
 Dim strFolder As String
 Dim strNewFolder As String
 Dim save_to_folder As String
 Dim strMyPath as String
 Dim intCount as Integer
 Dim 

 enviro = CStr(Environ("USERPROFILE"))

 sName = Item.Subject
 ReplaceCharsForFileName sName, "_"

 sSender = Item.Sender

 dtDate = Item.ReceivedTime
 sName = sSender & " - " & sName & ".msg"

 strNewFolder = Format(Date, "mm-dd-yyyy")
 strFolder = "C:\IT Documents\" & strNewFolder & "\"

 If Len(Dir(strFolder, vbDirectory)) = 0 Then
   MkDir (strFolder)
 End If

 save_to_folder = strFolder

 Item.SaveAs save_to_folder & sName, olMSG
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
     sChr As String _)

 sName = Replace(sName, "/", sChr)
 sName = Replace(sName, "\", sChr)
 sName = Replace(sName, ":", sChr)
 sName = Replace(sName, "?", sChr)
 sName = Replace(sName, Chr(34), sChr)
 sName = Replace(sName, "<", sChr)
 sName = Replace(sName, ">", sChr)
 sName = Replace(sName, "|", sChr)
End Sub

นี่คือรหัสที่ฉันกำลังคิดที่จะเพิ่ม

Do While True 
  strMyPath = strFolder & sName 
  If objFSO>FileExists(strMyPath) Then 
    intCount = intCount + 1 
    sName = Copy (" & intCount & ") 
  Else Exit Do 
  End If 
Loop

สิ่งนี้จะใช้ได้กับสิ่งที่ฉันพยายามทำหรือไม่ หรือจะดีกว่าถ้าเพิ่มเวลาต่อท้ายชื่อไฟล์