AW: Externe Daten senden - Bisheriger Code
21.10.2015 06:35:43
fcs
Hallo Matthias,
nachfolgend ein angepasster Code.
Es werden nach wie vor die E-Mail-Adressen in Spalte B abgearbeitet.
Der zugehörige Name des Attachments in Spalte A wird verarbeitet.
Die ergänzte Function fncFilePath kannst du auch in dein Tabellenblatt einbauen. Dann siehst du, wo der AttachmentName nicht vorhanden ist.
Gruß
Franz
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim strFile As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
'Attachmentnamen ermitteln aus linker Nachbarzelle und prüfen
strFile = fncPathFile(FileName:=cell.Offset(0, -1).Text, _
SubDir:="Scans", _
strWildCard:=".*", _
MainDir:=ThisWorkbook.Path) 'Parameter strWildCard ggf. weglassen
If Trim(cell.Offset(0, -1).Text) = "" Then
'do nothing
MsgBox "Zeile " & cell.Row & " - Empfänger: " & cell.Text & vbLf _
& "Kein Dateiname eingetragen" & vbLf & vbLf _
& "E-Mail wird nicht gesendet!", _
vbOKOnly + vbInformation, "Mail-Versand"
ElseIf strFile = "" Then
MsgBox "Zeile " & cell.Row & " - Empfänger: " & cell.Text & vbLf _
& "Folgende Datei existiert nicht:" & vbLf _
& ThisWorkbook.Path & "\Scans\" & cell.Offset(0, -1).Text & vbLf & vbLf _
& "E-Mail wird nicht gesendet!", _
vbOKOnly + vbInformation, "Mail-Versand"
Else
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
If strFile "" Then .Attachments.Add strFile
.Send
' .Display
End With
Set OutMail = Nothing
End If
End If
Next_Mailempfänger:
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Public Function fncPathFile(FileName As String, SubDir As String, _
Optional strWildCard As String = "", _
Optional MainDir As String) As String
Dim strResult As String, strPath As String
'strWildCard: Mit diesem Parameter kann die Suche nach dem Dateinamen variabeler werden
' "*" : Sucht nach einer Datei, die mit FileName beginnt
' ".*" : Sucht nach einer Datei mit FileName und beliebiger Namenserweiterung
' "*.pdf" : Sucht nach einer Datei, die mit FileName beginnt und .pdf endet
'Formelbeispiel in Tabellenblatt: =fncPathFile(A1;"Scans";"*") & TEXT(HEUTE();"")
'& TEXT(HEUTE();"") sorgt dafür, dass die Zelle bei Neu-Berechnung der Datei _
aktualisiert wird
On Error GoTo Fehler
If FileName "" Then
strPath = IIf(MainDir = "", ThisWorkbook.Path, MainDir) & Application.PathSeparator & _
SubDir
strResult = Dir(strPath & Application.PathSeparator & FileName & strWildCard)
If strResult = "" Then
fncPathFile = ""
Else
fncPathFile = strPath & Application.PathSeparator & strResult
End If
End If
Exit Function
Fehler:
fncPathFile = ""
End Function