Externe Daten senden - Bisheriger Code

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Externe Daten senden - Bisheriger Code
von: matthias
Geschrieben am: 19.10.2015 11:03:57

Hallo,
anbei der bisherige Code zum versenden von externen Daten per Email.
Dieser funktioniert auch. Jedoch möcht ich nicht immer den Pfad zur exteren Datei einfügen müssen. Deshalb bräuchte ich hier eine Suchfunktion
https://www.herber.de/bbs/user/100868.xlsm
Ich hoffe es kann mir jemand weiterhelfen.

Bild

Betrifft: AW: Externe Daten senden - Bisheriger Code
von: fcs
Geschrieben am: 21.10.2015 06:35:43
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


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Externe Daten senden - Bisheriger Code"