*.xlsm mit VBA automatisch versenden
05.04.2015 14:11:54
Patrick
Für meine Praxisarbeit habe ich mir in Excel eine Umfrage gebastelt, welche ich per Mail an die Teilnehmer versende.
Ich möchte den Teilnehmern das Leben so leicht wie möglich machen und via VBA das automatische Öffnen eines Mails mit dem bereits angefügten Anhang und der vorausgefüllten Mailadresse mit Klick auf einen Button ind der ausgefüllten Umfrage ermöglichen.
Das habe ich mit folgendem Code ganz gut hinbekommen:
Sub Grafik19_Klicken()
Dim Nachricht As Object, OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim AWS As String
'Aktive Arbeitsmappe wird als Mail gesendet
AWS = ThisWorkbook.FullName
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = "vorname.nachname@provider.ch"
.Subject = "Umfrage zur Praxisarbeit"
.attachments.Add AWS
.Body = ""
'Hier wird die Mail nochmals angezeigt
.Display
End With
Set OutApp = Nothing
Set Nachricht = Nothing
End Sub
Mache ich den weg manuell via Datei>Speichern und Senden>Als Anlage senden funktioniert es wunderbar.
Da die Datei aber im Vollbild-Modus startet (auch via VBA) möchte ich eben nicht diese Lösung anbieten.
Da ich VBA nicht selber programmieren kann suche ich mir die Lösung via google zusammen. Aber für dieses Problem habe ich keine Lösung gefunden.
Das Problem ist, dass die Datei beim Empfänger schreibgeschützt geöffnet wird. Das heisst, es müsste programmiert werden, dass beim Klick auf den Versenden-Button folgendes passiert:
1. Datei speichern unter
2. Mail wird geöffnet, mailadresse ist vorausgefüllt, die unter 1. gespeicherte Datei ist im Anhang. Benutzer muss nur noch auf senden klicken
3. beim schliessen der Umfrage soll die temporäre datei wieder gelöscht werden.
Dabei habe ich folgenden Code ausprobiert:
Sub Grafik19_Klicken()
'by Ramses
Dim strRec As String, strSend As String
Dim mypath As String
mypath = Application.ActiveWorkbook.Path
strRec = "vorname.nachname@provider.ch"
'oder Empfänger aus einer Zelle holen
'strRec = "irgendwer@irgendwo.de"
'Temporäre Arbeitsmappe aus der Tabelle erstellen
Sheets("Umfrage").Copy
'zu versendende geöffnete Mappe
strSend = ActiveWorkbook.Name
'Arbeitsmappe temporär speichern
ActiveWorkbook.SaveAs Filename:=mypath & "\" & strSend
'Wechseln auf Laufwerk und Verzeichnis
ChDrive Left(mypath, 2)
ChDir mypath
'Wenn kein Mailsystem installiert ist, wird die
'Mail nicht versendet
If Application.MailSystem xlNoMailSystem Then
Application.ActiveWorkbook.SendMail strRec, "Mail von " & Application.OrganizationName, _
False
Else
MsgBox "Kein verwendbares Mailsystem installiert"
End If
'Die temporäre Arbeitsmappe wieder schliessen
ActiveWorkbook.Close
' Die temporär erstellte Arbeitsmappe wieder löschen
End Sub
Habt ihr mir evtl. eine schlaue Lösung?
Vielen Dank im Voraus.
Viele Grüsse
Patrick