Dateien aus untersch. Verzeichnissen versenden

Sub senden() Dim Nachricht As Object, OutApp As Object Dim SavePath As String Dim AWS As String Dim File As String Dim vFile as String Dim to_ As String ThisWorkbook.Activate to_ = Sheets("Parameter").Range("Versand") vFile = ActiveSheet.Name SavePath = Application.ActiveWorkbook.path File = ActiveSheet.Name ActiveSheet.Copy 'Kopiert aktuelles Sheet in eine neue Mappe With ActiveWorkbook .Sheets(1).Name = "Print" .SaveAs SavePath & "\" & File End With With ActiveWorkbook .Save End With 'Aktive Arbeitsmappe wird als mail gesendet AWS = ActiveWorkbook.FullName Application.DisplayAlerts = False Set OutApp = CreateObject("Outlook.Application") 'InitializeOutlook = True Set Nachricht = OutApp.CreateItem(0) With Nachricht .To = to_ .Subject = "Report " & Date & " " & Time .Attachments.Add AWS .Display End With Set OutApp = Nothing Set Nachricht = Nothing Application.DisplayAlerts = True ActiveWorkbook.Close Kill AWS End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

... Versandprogramm übergeben werden?
Hallo Sepp, liebes Forum
Ich erlaube mir noch eine Anschlussfrage. Zum Teil will ich die Dateien per Outlook und zum Teil per Lotus Notes versenden.
Was wann zum Tragen kommt, frage ich mit Hilfe von Select Case ab. Wenn ein Versand mittels Notes erfolgt, habe ich die entsprechenden Variablen mit folgendem Aufruf an eine Subroutine übergeben.
Nun habe ich im Code von Sepp versucht eine Variable zu lokalisieren, die die einzelnen Dateinamen liefert und bin nicht fündig geworden
Kann mir jemand sagen, wie ich die zum Versandbestimmten Dateinamen der entsprechenden Funktion übergebe?
Vielen Dank!
Peter
'Code für Versand mit Lotus Notes
VersendeMail to_, cc_, bcc_, AWS 'mit AWS wurde bisher das entsprechende Attachment übergeben

Hallo Peter,
anbei ein Codebeispiel, wie man die Paramter übergeben kann. Ausserdem werden die Abhänge nicht in fixen Blöcken zugeteilt, sondern man kann die maximale Gesamtgrösse der Anhänge angeben. Ist dadurch etwas flexibler, wenn große und kleine Dateien versendet werden.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private OLApp As Object

Private Const cMaxSize As Long = 521000 'Maximale Gesamtgrösse der Anhänge in KB

Sub SendMail_Attachment()
Dim objFSO As Object, objF As Object
Dim strFile As String, TO_ As String
Dim AWS() As String
Dim lngR As Long, lngE As Long, lngSize As Long, lngS As Long
Dim i As Integer

Set objFSO = CreateObject("Scripting.FileSystemObject")

With ThisWorkbook

    TO_ = .Sheets("Parameter").Range("Versand")

    lngE = Application.Max(3, .Sheets("Dateien").Cells(Rows.Count, 1).End(xlUp).Row)

    For lngR = 3 To lngE

        strFile = .Sheets("Dateien").Cells(lngR, 1).Text & "\" & .Sheets("Dateien").Cells(lngR, 2).Text

        If Dir(strFile) <> "" Then

            Set objF = objFSO.GetFile(strFile)
            lngSize = lngSize + objF.Size

            If lngR < lngE Then
                Set objF = objFSO.GetFile(.Sheets("Dateien").Cells(lngR + 1, 1).Text & _
                    "\" & .Sheets("Dateien").Cells(lngR + 1, 2).Text)
                lngS = objF.Size
            Else
                lngS = 0
            End If

            Redim Preserve AWS(i)
            AWS(i) = strFile
            i = i + 1

            If lngSize + lngS > cMaxSize Or lngR = lngE Then
                i = 0
                lngSize = 0
                SendWith_OutLook TO_, Subject:="Report " & Date & " " & Time, Attachments:=AWS
                Erase AWS
            End If

        End If

    Next

End With

Set objFSO = Nothing
Set objF = Nothing
Set OLApp = Nothing
End Sub

Sub SendWith_OutLook(TO_ As Variant, Optional CC_ As Variant, Optional BCC_ As Variant, _
    Optional Subject As String, Optional Attachments As Variant)

Dim OMail As Object
Dim strTO As String, strCC As String, strBCC As String
Dim vAttatch As Variant, n As Integer

If IsArray(TO_) Then
    strTO = Join(TO_, ";")
Else
    strTO = TO_
    End If

If IsArray(CC_) Then
    strCC = Join(CC_, ";")
ElseIf Not IsMissing(CC_) Then
    strCC = CC_
    End If

If IsArray(BCC_) Then
    strBCC = Join(BCC_, ";")
ElseIf Not IsMissing(BCC_) Then
    strBCC = BCC_
    End If

If IsArray(Attachments) Then
    vAttatch = Attachments
ElseIf Not IsMissing(Attachments) Then
    Redim vAttatch(0)
    vAttatch(0) = Attachments
End If

If OLApp Is Nothing Then
    Set OLApp = CreateObject("Outlook.Application")
End If

Set OMail = OLApp.CreateItem(0)

With OMail
    .To = strTO
    .CC = strCC
    .BCC = strBCC
    .Subject = Subject
    For n = 0 To UBound(vAttatch)
        If Not IsEmpty(vAttatch) Then .Attachments.Add vAttatch(n)
    Next
    .Display
End With

Set OMail = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Dateien aus untersch. Verzeichnissen versenden

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread