このスクリプトでメールを送信します。メールの件名に日付を追加する日付入力ボックスを追加しました。間違った日付を指定すると、電子メールを受け入れて送信します。
Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim strDate As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
strDate = InputBox("Insert date in format dd/mm/yy", "User date", Format(No(),"dd/mm/yyyy"))
If IsDate(strDate) Then
strDate = Format(CDate(strDate), "dd/mm/yyyy")
MsgBox strDate
Else
MsgBox "Wrong date format"
End if
Set sh = Sheets("Sheet2")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("c").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("d1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile" & strDate
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display 'Or use Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub