Geöfnette Ecxel 2003 Datei per Makro versenden

Hallo Forum,

ich muss einen absenden button in Excel 2003 so programieren das sich die gesamte gerade geöfnete datei(mit allen sheets), an mehrere empfänger sendet (ca.8).

Dieses makro funktioniert in word sehr gut, ich bekomme es aber in excel nicht zum laufen, entweder sendet er nur das aktive sheet, oder er macht garnichts.

Private Sub CommandButton2_Click()
'das gesamte dokument per mail verschicken
'Options.SendMailAttach = True
With ActiveDocument _
.MailEnvelope.Item
.To = "ich@ich.com;ich2@ich2.com"
.Subject = "Test"
.Send
End With
End Sub

Ich habe auch einige andere möglichkeiten gefunden, bei welchen sich aber ein outlook fenster öffnet, oder sich dieses lästige fenster, bei welchem man das senden bestätigen muss, für jede eingetragene Adresse öffnet. Dies soll aber nicht der fall sein.

Ich hoffe ihr könnt mir helfen, und ja ich weiß das es dazu schon beiträge gibt, ich aber nichts passendes gefunden hab, da ich eigentlich nicht viel ahnung von vba/vbs? hab.

Vielen Dank

Nico

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 163437

Url: https://administrator.de/contentid/163437

Ausgedruckt am: 16.11.2024 um 05:11 Uhr

5 Kommentare

Neuester Kommentar

Hallo simon-ni!

Mit diesem Code wird das Standard-Mail-Programm verwendet. In meinem Fall ist das Thunderbird, bei dem 1 mal mit OK für alle bestätigt werden muss. Der Versuch die Arbeitsmappe auf andere Weise zu versenden ist leider daran gescheitert, weil die Arbeitsmappe geöffnet ist.

Private Sub CommandButton2_Click()
    Dim An(1 To 8) As String
    
    An(1) = "a@xy.de"  
    An(2) = "b@xy.de"  
    '...  
    An(8) = "h@xy.de"  

    ActiveWorkbook.SendMail Recipients:=An, Subject:="Test"  
End Sub

Gruß Dieter

Hi,
hier noch ein paar Möglichkeiten.

Eine Möglichkeit die geöffnete Excel-Datei zu versenden funktioniert so:

 
    sAddr = "mail1@domain.de;mail1@domain.de"  
    sBetreff = "betraff"  
    Application.Dialogs(xlDialogSendMail).Show sAddr, sBetreff

Hier musst Du noch 1 Klick zum versandt machen (egal wie viele Empfänger)

Ein wenig aufwändiger, aber weitaus flexibler ist diese Methode (ich geh mal davon aus, dass Du Outlook hast).
Unter ->Extras->Verweise musst Du dazu noch den Verweis auf die "Microsoft Outlook XX Object Library" aktivieren.

Hiermit kannst Du noch einen Text in die Mail einfügen (.Body) und auch mehrere Dateien anhängen.
Die Zeile "SendKeys %s" sorgt dafür, das Du im Outlook nicht mehr auf "Senden" klicken musst

 
    Dim olApp As Outlook.Application
    Dim olNamespace As Namespace
    Dim objMailItem As MailItem
    Dim objFolder As mapiFolder
    
    Set olApp = CreateObject("Outlook.Application")  
    Set olNamespace = olApp.GetNamespace("MAPI")  
    Set objFolder = olNamespace.GetDefaultFolder(olFolderInbox)
    Set objMailItem = objFolder.Items.Add(olMailItem)
    
    With objMailItem
        .To = "mail1@domain.de;mail1@domain.de"  
        .Subject = ""  
        .Body = ""  
        .Attachments.Add "c:\tmp\test.xls"  
        .Display
    End With
    olApp.ActiveWindow
    SendKeys "%s"  

Funktioniert einwandfrei, danke

Bei der ersten möglichkeit öffnet sich ein outlook fenster, was nicht passieren soll.

Für die zweite möglichkeit müsste ich die policy ändern, was ich leider nicht einfach so machen kann.

Trotzdem danke für die Mühe.

Hallo,

ich steh vor einer etwas spezielleren Herausforderung:

ich habe eine Ausgangsdatei, welche ich mittels nachfolgendem makro, nach einem Kriterium in 18 einzelne Dateien aufsplitte

Option Explicit
Sub Pivotrefresh()

    Worksheets("Pivot").Activate  
    ActiveSheet.PivotTables("PivotTable8").PivotCache.Refresh  
    
End Sub

Sub Start()

Dim I As Byte, K As Integer, X As Integer, Y As Integer
Dim Kriterium As String, Pfad As String
Dim AW As String

'Dies bitte anpassen => Pfad, wo gespeichert werden soll  
Pfad = "C:\"  

'Bildschirmaktualisierung abschalten  
Application.ScreenUpdating = False

'Datenbasis neu aufstellen  
Pivotrefresh

'Zum richtigen Tabellenblatt springen  
Worksheets("Quelle").Activate  

'Ende der Quelle finden  
Worksheets("Quelle").Cells(Rows.Count, 2).End(xlUp).Activate  
K = Replace(ActiveCell.Address(False, False), "B", "")  

'Beginn in Zeile => Pivottabelle  
I = 5

'Loslaufen  
Do

    'Ersten Eintrag der zu filternden Kriterien  
    Kriterium = Worksheets("Pivot").Cells(I, 1)  
      
    'Für jedes Kriterium ein Tabellenblatt  
    Worksheets.Add
    ActiveSheet.Name = Kriterium
    
    'Zunächst die Überschriften setzen  
    Worksheets(Kriterium).Cells(1, 1) = Worksheets("Quelle").Cells(1, 1)  
    Worksheets(Kriterium).Cells(1, 2) = Worksheets("Quelle").Cells(1, 2)  
    Worksheets(Kriterium).Cells(1, 3) = Worksheets("Quelle").Cells(1, 3)  
    Worksheets(Kriterium).Cells(1, 4) = Worksheets("Quelle").Cells(1, 4)  
    Worksheets(Kriterium).Cells(1, 5) = Worksheets("Quelle").Cells(1, 5)  
    Worksheets(Kriterium).Cells(1, 6) = Worksheets("Quelle").Cells(1, 6)  
    Worksheets(Kriterium).Cells(1, 7) = Worksheets("Quelle").Cells(1, 7)  
    Worksheets(Kriterium).Cells(1, 8) = Worksheets("Quelle").Cells(1, 8)  
    Worksheets(Kriterium).Cells(1, 9) = Worksheets("Quelle").Cells(1, 9)  
    Worksheets(Kriterium).Cells(1, 10) = Worksheets("Quelle").Cells(1, 10)  
    Worksheets(Kriterium).Cells(1, 11) = Worksheets("Quelle").Cells(1, 11)  
    Worksheets(Kriterium).Cells(1, 12) = Worksheets("Quelle").Cells(1, 12)  
    Worksheets(Kriterium).Cells(1, 13) = Worksheets("Quelle").Cells(1, 13)  
    Worksheets(Kriterium).Cells(1, 14) = Worksheets("Quelle").Cells(1, 14)  
    Worksheets(Kriterium).Cells(1, 15) = Worksheets("Quelle").Cells(1, 15)  
    Worksheets(Kriterium).Cells(1, 16) = Worksheets("Quelle").Cells(1, 16)  
    Worksheets(Kriterium).Cells(1, 17) = Worksheets("Quelle").Cells(1, 17)  
        
    'Zeile in jedem Tabellenblatt wieder auf zwei setzen  
    Y = 2
    
    'Die Quelle vom Anfang bis Ende durchlaufen  
    For X = 2 To K
      
        'Sofern Kriterium entspricht, kopieren  
        If Worksheets("Quelle").Cells(X, 2) = Kriterium Then  
            
            Worksheets(Kriterium).Cells(Y, 1) = Worksheets("Quelle").Cells(X, 1)  
            Worksheets(Kriterium).Cells(Y, 2) = Worksheets("Quelle").Cells(X, 2)  
            Worksheets(Kriterium).Cells(Y, 3) = Worksheets("Quelle").Cells(X, 3)  
            Worksheets(Kriterium).Cells(Y, 4) = Worksheets("Quelle").Cells(X, 4)  
            Worksheets(Kriterium).Cells(Y, 5) = Worksheets("Quelle").Cells(X, 5)  
            Worksheets(Kriterium).Cells(Y, 6) = Worksheets("Quelle").Cells(X, 6)  
            Worksheets(Kriterium).Cells(Y, 7) = Worksheets("Quelle").Cells(X, 7)  
            Worksheets(Kriterium).Cells(Y, 8) = Worksheets("Quelle").Cells(X, 8)  
            Worksheets(Kriterium).Cells(Y, 9) = Worksheets("Quelle").Cells(X, 9)  
            Worksheets(Kriterium).Cells(Y, 10) = Worksheets("Quelle").Cells(X, 10)  
            Worksheets(Kriterium).Cells(Y, 11) = Worksheets("Quelle").Cells(X, 11)  
            Worksheets(Kriterium).Cells(Y, 12) = Worksheets("Quelle").Cells(X, 12)  
            Worksheets(Kriterium).Cells(Y, 13) = Worksheets("Quelle").Cells(X, 13)  
            Worksheets(Kriterium).Cells(Y, 14) = Worksheets("Quelle").Cells(X, 14)  
            Worksheets(Kriterium).Cells(Y, 15) = Worksheets("Quelle").Cells(X, 15)  
            Worksheets(Kriterium).Cells(Y, 16) = Worksheets("Quelle").Cells(X, 16)  
            Worksheets(Kriterium).Cells(Y, 17) = Worksheets("Quelle").Cells(X, 17)  
            Y = Y + 1
            
        End If
        
    Next X
    
    'Neue Mappe aufmachen und Tabellenblatt verschieben  
    Sheets(Kriterium).Move
    ActiveWorkbook.SaveAs Filename:=Pfad & "\" & Kriterium & ".xls", FileFormat:= _  
        xlNormal, CreateBackup:=False
    
    'Aktives Tabellenblatt schließen. Änderungen wurden bereits gespeichert!  
    ActiveWorkbook.Close
    
    'Nächste Runde  
    I = I + 1
    
Loop Until Worksheets("Pivot").Cells(I, 1) = "Gesamtergebnis"  

AW = MsgBox("Der Vorgang wurde abgeschlossen!", vbOKOnly + vbInformation + vbSystemModal, "Hinweis")  

Application.ScreenUpdating = True

End Sub

ich möchte jetzt jede Datei an eine spezielle e-mail-adresse verschicken z.B. Datei mit Kriterium A an email-adresse Y, Datei mit Kriterium B an email-adresse Z, usw.

ist das möglich, bzw. ist das mit einem makro möglich?

gelöst Frage Microsoft Microsoft Office

Mehr von simon-ni

Exchange Online Öffentliche Ordner EditOwnedItems funktioniert nichtsimon-ni

PHP mail() Datei versendensimon-ni - 3 Kommentare

Logon Script wird trotz deaktivierung ausgeführtsimon-ni - 4 Kommentare

Microsoft DNS URL forward zu IPsimon-ni - 2 Kommentare

Heiß diskutiert