Office: Makro erstellen: PDF erstellen und als Mail verschicken.

Hallo,
hatte vor zwei Jahren den Code geschrieben hatte auch gut funktioniert gehabt.

Wollte es nun für was anderes nutzen aber dieser Makro funktioniert nicht mehr.

Habe in meiner Recherche gesehen das öffnen des outlook auch jetzt anders heißt.

Vorher: Set app = CreateObject("Outlook.Application")
Jetzt: Application.Dialogs(xlDialogSendMail).Show

Habe es selber nicht geschaft den Makro anzupassen das es läuft.

Kurz was ich machen wollte:

Ein Excelblatt soll als PDF (Temporär reicht aus) erstellt werden und als Anhang gesendet werden.

Die PDF Datei soll wie im Range A44 heißen. (Weil sich der Dateiname immer ändert)
Textfeld im Mail auch nach einem Feld z.B. A45
Empfänger CC Subject usw. alles am besten nach einem bestimmten Feld.

Was muss ich in diesem Makro korrigieren?


Sub DateialsPDFsenden()
Dim app As Object
Dim file As String
Dim isNew As Boolean

file = Range("A44") & ".pdf"

ActiveSheet.ExportAsFixedFormat xlTypePDF, Environ("TEMP") & "\" & file

On Error Resume Next
Set app = GetObject(, "Outlook.Application")
If app Is Nothing Then
Set app = CreateObject("Outlook.Application")
isNew = True
End If

With app.CreateItem(0)
.SentOnBehalfOfName = "meine@email.com"
.To = "email@email.com;"
.CC = "2email@email.com;"
.BCC = ""
.Subject = Range("A53")

.Body = "Dear colleagues," & vbCrLf & "" & vbCrLf & "This is a test" & vbCrLf & "" & vbCrLf & "" & vbCrLf & "" & vbCrLf & "Beste Grüße" & vbCrLf & "" & vbCrLf & ""

.Attachments.Add Environ("TEMP") & "\" & file
.ReadReceiptRequested = False
.Display 'Email anzeigen

End With

If isNew Then app.Quit
End Sub

 

Hallo,

das ist ja extrem informativ! Wie soll ich dir da helfen können.

1) Das Makro muss ja in einer Zeile hängen bleiben. Diese Zeile möchte ich wissen.
2) Es muss eine Fehlernummer angezeigt werden zusammen mit einer Fehlerbeschreibung. Beides möchte ich ebenfalls wissen.
Wenn du dies übermittelst, kann ich dir eventuell helfen.

 

Hallo sorry für das späte zurückmelden.
Habe diesen Code jetzt aktualisiert und es funktioniert zum Glück.

1. Könnte man es noch so ändern das nicht unbedingt ein PDF gespeicherten werden muss?




Sub Saveaspdfandsend()

'


Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = "mail@mail.com"
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub