| SendMail, Send, Display |
|
|
| Makro zum Versenden von Excelblättern. Hier wird eine neue Datei angelegt, damit das ganze ohne |
| VBA Code versendet wird: |
|
| Sub ExcelSheet_Versenden() |
| Dim strMailEmpfaenger As String |
| i = Application.ActiveWorkbook.Path |
| strMailEmpfaenger = "Hier Mail-Adresse eintragen" |
| strTempName = "Abholauftrag Import.xls" |
| Sheets("Dein Tabellenname").Copy |
| ChDir i |
| ActiveWorkbook.SaveAs Filename:= i & "\" & strTempName |
| If Application.MailSystem <> xlNoMailSystem Then |
| Application.ActiveWorkbook.SendMail strMailEmpfaenger, _ |
| "Abholauftrag Import von " & Application.OrganizationName, False |
| End If |
| ActiveWorkbook.Close |
| 'Die temporär erstellte Arbeitsmappe wieder löschen |
| Kill i & "\" & strTempName |
| End Sub |
|
| |
|
| Mail aus Excel mit Outlook versenden (ohne Sicherheitsabfrage): |
|
| Sub MailVersenden() |
| Dim outl, Mail As Object |
| Set outl = CreateObject("Outlook.Application") |
| Set Mail = outl.CreateItem(0) |
| Mail.Subject = "Bestellung " & VBA.Date |
| Mail.To = "sales@company.info" |
| Mail.CC = "admin@company.info; purch@company.info, boss@company.info" |
| Mail.BCC = "secret@company.info" |
| 'Wichtigkeit Hoch (1 = normal, 0 = niedrig) |
| Mail.Importance = 2 |
| 'Standardtext |
| Mail.body = "Hallo Kollegen!" & vbCrLf & vbCrLf & _ |
| "Anbei unser Auftrag." & vbCrLf & vbCrLf & _ |
| "Mit freundlichen Grüssen" & vbCrLf & vbCrLf & _ |
| "Euer Sales-Team" & vbCrLf & vbCrLf |
| 'Eine Datei auf Laufwerk D:\ als Anhang mitsenden... |
| Mail.Attachments.Add "D:\Datei001.xls" |
| 'oder: die aktive Exceldatei als Anhang mitsenden... |
| Mail.Attachments.Add ThisWorkbook.FullName |
| 'Mail anzeigen |
| Mail.Display |
| 'Ein sofortiger Mail-Versand geht in Firmen wegen Sicherheitseinstellungen oft nicht: |
'Mail.Send |
| 'aber es gibt eine Lösung mit SendKeys per Windows Scripting Host (Verweis ins VB-Projekt einfügen!): |
| Dim WshShell |
| Set WshShell = CreateObject("WScript.Shell") |
| WshShell.AppActivate Mail |
| 'Sendet ein "Alt-S", Outlook sendet Mail sofort ohne Sicherheitsabfrage: |
| WshShell.SendKeys ("%s") |
| Set Mail = Nothing |
| Set outl = Nothing |
| Set WshShell = Nothing |
| End Sub |
|
| Hinweise zur Lösung oben: das Versenden von zahlreichen Mails hintereinander sollte man hier unterlassen, |
| wenn der Bildschirm unruhig flackert (also ausschalten, wegschauen etc...). |
| Pech hat man auch, wenn die Rechtschreibprüfung eingeschaltet ist; diese lässt leider (noch) nicht |
| umgehen; bin hier für jeden Tipp dankbar... |
| |
|
| Mail aus Excel mit Outlook versenden: |
|
| Sub Versenden() |
| Application.ScreenUpdating = False |
| Application.DisplayStatusBar = True |
| bolStatusBar = Application.DisplayStatusBar |
|
| Set objOutlook = CreateObject("Outlook.Application") |
|
| strRecipient = "Preisanfragen_AV" |
| strFile = range("a2") |
|
| Application.StatusBar = "Sende Datei " & strFile & " an " & strRecipient |
| Set objOutlookMsg = objOutlook.CreateItem(olMailItem) |
| With objOutlookMsg |
| Set objOutlookRecip = .Recipients.Add(strRecipient) |
| objOutlookRecip.Type = olTo |
| .Subject = strSubject |
| .Body = strFile |
| objOutlookRecip.Resolve |
| .Send |
| End With |
|
| Set objOutlook = Nothing |
| Application.StatusBar = False |
| Application.DisplayStatusBar = bolStatusBar |
| End Sub |
|
| |
|
| Mail mit Netscape Messenger: |
|
| Öffnet den Netscape Messenger und hängt die aktuelle Datei als Anhang an. |
| Netscape Messenger ist hier der Standard-Mailclient. |
|
| Sub mail_ohne_outlook() |
| Application.Dialogs(xlDialogSendMail).Show "dein.name@hallo.com", "Ihre heutige Anfrage" |
| End Sub |
|
| |
|
| Mail aus Excel über Lotus Notes (Notes-Client muss installiert sein): |
|
| 'Set up the objects required for Automation into lotus notes |
| Public Sub SendNotesMail(Subject As String, Attachment As String, _ |
| Recipient As String, BodyText As String, SaveIt As Boolean) |
| Dim Maildb As Object 'The mail database |
| Dim UserName As String 'The current users notes name |
| Dim MailDbName As String 'THe current users notes mail database name |
| Dim MailDoc As Object 'The mail document itself |
| Dim AttachME As Object 'The attachment richtextfile object |
| Dim Session As Object 'The notes session |
| Dim EmbedObj As Object 'The embedded object (Attachment) |
|
| 'Start a session to notes |
| Set Session = CreateObject("Notes.NotesSession") |
|
| 'Get the sessions username and then calculate the mail file name |
| 'You may or may not need this as for MailDBname with some systems you can pass an empty string |
| UserName = Session.UserName |
| MailDbName = Left$(UserName, 1) & Right$(UserName, _ |
| (Len(UserName) - InStr(1, UserName, " "))) & ".nsf" |
|
| 'Open the mail database in notes |
| Set Maildb = Session.GETDATABASE("", MailDbName) |
| If Maildb.ISOPEN = True Then |
| 'Already open for mail |
| Else |
| Maildb.OPENMAIL |
| End If |
|
| 'Set up the new mail document |
| Set MailDoc = Maildb.CREATEDOCUMENT |
| MailDoc.Form = "Memo" |
| MailDoc.sendto = Recipient |
| MailDoc.Subject = Subject |
| MailDoc.Body = BodyText |
| MailDoc.SAVEMESSAGEONSEND = SaveIt |
|
| 'Set up the embedded object and attachment and attach it |
| If Attachment <> "" Then |
| Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment") |
| Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment, "Attachment") |
| MailDoc.CREATERICHTEXTITEM ("Attachment") |
| End If |
|
| 'Send the document |
| MailDoc.PostedDate=Now() 'Gets the mail to appear in the sent items folder |
| MailDoc.SEND 0, Recipient |
|
| 'Clean Up |
| Set Maildb = Nothing |
| Set MailDoc = Nothing |
| Set AttachME = Nothing |
| Set Session = Nothing |
| Set EmbedObj = Nothing |
| End Sub |
|
| |
|
| Mailversand aus Worksheet heraus: |
|
| Die Daten für die Generierung der Email stehen in den Spalten A bis K: |
| A: Name des Empfängers |
| B: Emailadresse des Empfängers |
| C: Emailadresse für Kopie offiziell (optional) |
| D: Emailadresse für Kopie inoffizell (optional) |
| E: Betreff |
| F bis J: Texte, aus denen der Nachrichtentext generiert wird |
| K: Anhang (vollständiger Pfad & Dateiname - optional) |
|
| Über einen CommandButton in der Tabelle wird der Emailversand durchgeführt. |
| Im Code ist noch jede Menge auskommentiert, weil möglichst viele Möglichkeiten |
| für den Emailversand berücksichtigt werden sollen. So können verschiedene Anhänge |
| mitgesendet werden, der Emailversand kann automatisch oder über den Senden-Dialog |
| von Outlook erfolgen oder die weitere Makroausführung kann bis zum Beenden von |
| Outlook blockiert werden. |
|
| Sub cmdVersenden_Click() |
| Dim objOlApp As Outlook.Application |
| Dim objMailItem As Outlook.MailItem |
| Dim objMailRecip As Outlook.Recipient |
| Dim strMailAddress As String, strMailAddrCC As String |
| Dim strMailAddrBCC As String, strMailSubj As String |
| Dim strMailBody As String, strMailAttach As String |
| With ActiveSheet |
| If IsEmpty(.Cells(ActiveCell.Row, 11).End(xlToLeft)) Then |
| MsgBox "Bitte wählen Sie einen gültigen " & _ |
| "Tabelleneintrag für den Email-Versand aus.", vbExclamation |
| Exit Sub |
| End If |
| 'Die Daten für die Email befinden sich in den Spalten A bis K der Zeile mit der aktiven Zelle. |
| 'Emailadressen auslesen |
| strMailAddress = .Range("B" & ActiveCell.Row) |
| If Not IsEmpty(.Range("C" & ActiveCell.Row)) Then |
| strMailAddrCC = .Range("C" & ActiveCell.Row) |
| End If |
| If Not IsEmpty(.Range("D" & ActiveCell.Row)) Then |
| strMailAddrBCC = .Range("D" & ActiveCell.Row) |
| End If |
| 'Betreff der Nachricht auslesen |
| strMailSubj = .Range("E" & ActiveCell.Row) |
| 'Nachricht generieren |
| strMailBody = strMailBody & .Range("F" & ActiveCell.Row) & " " & _ |
| .Range("A" & ActiveCell.Row) & "," & vbLf & vbLf |
| strMailBody = strMailBody & .Range("G" & ActiveCell.Row).Text & "." & _ |
| vbLf & vbLf |
| strMailBody = strMailBody & .Range("H" & ActiveCell.Row) & " ( " & _ |
| Now & " ) " & vbLf & vbLf |
| 'Abschluss und Absender hinzufügen |
| strMailBody = strMailBody & .Range("I" & ActiveCell.Row) & vbLf & _ |
| .Range("J" & ActiveCell.Row) & vbLf & vbLf |
| 'Pfad & Dateiname des Anhangs einlesen |
| strMailAttach = .Range("K" & ActiveCell.Row) |
| 'Objektvariable für Anwendung festlegen |
| Set objOlApp = CreateObject("Outlook.Application") |
| On Error GoTo lNoOutlook |
|
| If objOlApp Is Nothing Then _ |
| Set objOlApp = CreateObject("Outlook.Application") |
| 'Objektvariable für neues Outlook-Element festlegen |
| Set objMailItem = objOlApp.CreateItem(olMailItem) |
| 'Tritt beim Erstellen der Email ein Fehler auf, wird eine Fehlermeldung angezeigt. |
| On Error GoTo lNoSend |
| |
| With objMailItem |
| 'Empfänger der Mail wird in das Adressfeld "An:" geschrieben |
| Set objMailRecip = .Recipients.Add(strMailAddress) |
| '2. Empfänger für "Kopie offiziell" kennzeichnen |
| If strMailAddrCC <> "" Then |
| Set objMailRecip = .Recipients.Add(strMailAddrCC) |
| objMailRecip.Type = olCC |
| End If |
| '3. Empfänger für "Kopie inoffiziell" kennzeichnen |
| If strMailAddrBCC <> "" Then |
| Set objMailRecip = .Recipients.Add(strMailAddrBCC) |
| objMailRecip.Type = olBCC |
| End If |
|
| 'Betreff der Mail wird in das Feld "Betreff:" geschrieben |
| objMailItem.Subject = strMailSubj |
| 'Der Text der Nachricht wird übertragen |
| objMailItem.Body = strMailBody |
|
| 'Falls ein Anhang mitgesendet wird |
| If strMailAttach <> "" Then |
| 'Positon des Anhangs festlegen |
| 'Einbetten einer Anlage in das Element |
| '.Attachments.Add Source:=strMailAttach, Type:=olByValue ', DisplayName:="Dateianhang" |
| 'Wird DisplayName nicht angegeben, wird der Dateiname in der Mail angezeigt. |
| 'DisplayName kann verwendet werden, um dem Anhang eine andere Bezeichnung zu geben. |
| |
| 'Erstellen einer Verknüpfung zu einem Outlook-Element z.B. Kontakt-Element |
| '.Attachments.Add Source:=strMailAttach, Type:=olEmbeddedItem |
| 'Datei von einem Server durch Verknüpfen anhängen |
| '.Attachments.Add Source:=strMailAttach, Type:=olByReference |
| 'OLE Anhang |
| '.Attachments.Add Source:=strMailAttach, Type:=olOLE |
| End If |
| 'Übermittlungsbestätigung anfordern |
| '.OriginatorDeliveryReportRequested = True |
| |
| 'Lesebestätigung anfordern |
| '.ReadReceiptRequested = True |
| |
| 'Email in den "Gesendeten Objekten" speichern |
| '.Save |
| |
| 'Email als TXT-Datei speichern. Ohne Pfadangabe wird die Datei im Standard-Verzeichnis |
| 'gespeichert... |
| '.SaveAs .Subject & ".txt", olTXT |
| |
| 'Direktes Senden der Email; ohne Onlineverbindung wird die Mail im Postausgang abgelegt |
| '.Send |
| |
| 'Email-Dialog anzeigen |
| .Display |
| |
| 'Dialog mit Bindung des Fensters; diese Einstellung ist beim Versenden von Mails mit |
| 'Anhängen nicht empfehlenswert, weil während des Versendens keine weitere Makro- |
| 'ausführung möglich ist |
| 'MsgBox "Die Makroausführung wird bis zur Beendigung" & vbLf & _ |
| "von MS Outlook unterbrochen.", vbInformation |
| '.Display (True) |
| End With |
| End With |
| GoTo lSetObjects |
|
| lNoSend: |
| MsgBox vbTab & "Eine E-Mail an die Adresse " & vbCrLf & vbCrLf & _ |
| vbTab & EmailEmpfänger & vbCrLf & vbCrLf & _ |
| "kann leider NICHT automatisch versendet werden." |
| GoTo lSetObjects |
|
| lNoOutlook: |
| MsgBox "Microsoft Outlook ist nicht installiert oder es ist kein" & vbLf & _ |
| "Verweis auf die Microsoft Outlook Library gesetzt.", vbCritical |
| GoTo lSetObjects |
|
| lSetObjects: |
| Set objOlApp = Nothing |
| Set objMailItem = Nothing |
| Set objMailRecip = Nothing |
| End Sub |
|
zurück