Hallo,
habe ein Makro erstellt, es wird u.a. das Tabellenblatt (Auftrag) als xlsm verschickt, ich möchte aber das Format PDF, Die Anlage soll als PDF vermailt werden.
Danke, hier mein Makro
Sub Vertrieb_FT_Mail_weg()
If Not leer_nicht_leer() Then
Dim Ad$, K$, B$, t$, T1$, T2$, T3$, T5$, T6$, T7$, T8$, T9$, T4$, T0$, P1$, P2$, Text
Ad = Range(„N30“).Value
B = „(“ & Range(„E4“).Value & „)“ & " Auftrag zur Schadenbesichtigung // Schaden " & Range(„D6“).Value
T1 = „Sehr geehrte Damen und Herren,“
T2 = „im Anhang erhalten Sie einen (“ & Range(„B5“).Value & „)“ & " Auftrag zur Schadenbesichtigung. Bitte vereinbaren Sie umgehend"
T3 = „einen Ortstermin. Bitte informieren Sie den zuständigen Betreuer über die Terminvereinbarung.“
T5 = " "
T6 = " "
T7 = "Diese senden Sie bitte per E-Mail, als PDF, an [email protected]. "
T8 = „Bitte geben Sie im Betreff die Schadennummer an.“
T9 = „Bei Fragen wenden Sie sich bitte an den zuständigen Sachbearbeiter.“
T4 = „Mit freundlichen Grüßen“
T0 = „Ihre SV SparkassenVersicherung“
P1 = „C:\Users\gunag\Documents\test“
P2 = Range(„D6“) & („E5“)
MailErstellen Ad, K, B, T1, T2, T3, T5, T6, T7, T8, T9, T4, T0, P1, P2
Datensatzerstellen
Mail_Weg_Postk
End If
End Sub
Sub MailErstellen(Adr$, Kopie$, Betrifft$, Text$, Text2$, Text3$, Text5$, Text6$, Text7$, Text8$, Text9$, Text4$, Text0$, Pfad$, Pfad2$)
Dim sText As String, sText1 As String, sEmpfang As String, sBetrifft As String
Dim session As Object, db As Object, doc As Object, rtobject As Object
Dim rtitem As Object, sKopie As String, AttachMe As Object, AttachMe2 As Object, DerAnhang As Object
Dim user As String, server As String, mailfile As String, sBlindKopie As String
Dim vAn As Variant, vCopy As Variant, vBlind As Variant, sAnhang As String, sAnhang2 As String
Dim strDoc As String
'*** Mail erstellen
'sText = T1 & T2 & T3 & T4
sText = Text & vbCrLf & vbCrLf & Text2 & vbCrLf & Text3 & vbCrLf & vbCrLf & Text5 & vbCrLf & Text6 & vbCrLf & Text7 & vbCrLf & Text8 & vbCrLf & vbCrLf & Text9 & vbCrLf & vbCrLf & Text4 & vbCrLf & Text0
sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
' sEmpfang = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
sEmpfang = Adr ' Einträge durch " ; " getrennt
sBetrifft = Betrifft ' die Betreffzeile
' sKopie = Kopie
' sKopie = "[email protected]" ' Einträge durch " ; " getrennt
' sBlindKopie = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
vAn = Split(sEmpfang, " ; ") ' Empfänger Array
sAnhang = Range("D6") & ("E5")
sAnhang2 = Range("D6") & ("E5")
If Len(sKopie) > 0 Then vCopy = Split(sKopie, " ; ") 'cc Array
If Len(sBlindKopie) > 0 Then vBlind = Split(sBlindKopie, " ; ") 'bcc Array
Set session = CreateObject("notes.notessession") ' Notes muss gestartet sein
user = session.UserName
server = session.GetEnvironmentString("MailServer", True)
mailfile = session.GetEnvironmentString("MailFile", True)
Set db = session.GETDATABASE(server, mailfile)
Set doc = db.CreateDocument()
doc.Form = "Memo"
doc.SendTo = vAn ' an array
If Len(sKopie) > 0 Then doc.copyto = vCopy 'cc Array
If Len(sBlindKopie) > 0 Then doc.blindcopyto = vBlind 'bcc Array
doc.Subject = sBetrifft ' die Betreffzeile
Set rtitem = doc.CREATERICHTEXTITEM("body")
Call rtitem.APPENDTEXT(sText)
doc.SaveMessageOnSend = True
doc.ReplaceItemValue("ReturnReceipt", "1") = True
doc.PostedDate = Now
'*****************Datei speichern, schliessen und versenden*************
Set wkbMappe = Workbooks(Range(„D6“) & Range(„E5“))
If Not wkbMappe Is Nothing Then wkbMappe.Save
strDoc = ActiveWorkbook.Path & „“ & ActiveWorkbook.Name
Application.Quit
’ **********************************************************************
If sAnhang <> "" Then
Set AttachMe = doc.CREATERICHTEXTITEM(strDoc)
Set DerAnhang = AttachMe.EMBEDOBJECT(1454, "", strDoc)
End If
'*******************************
Call doc.Send(False)
Aufraeumen:
On Error Resume Next
Set rtitem = Nothing
Set AttachMe = Nothing
Set DerAnhang = Nothing
Set db = Nothing
Set doc = Nothing
Set session = Nothing
Exit Sub
Fehler:
Resume Aufraeumen
End Sub
Sub Datensatzerstellen()
’ Dim db As DAO.database, rs As DAO.Recordset
’ Set objDBEngine = CreateObject(„DAO.DBEngine.120“)
’ Set db = OpenDatabase(„W:\SH-Allg\ProfClaim\TaskForce\TaskF_BE.accdb“, False, False, „;PWD=Task234“)
’ Set rs = db.OpenRecordset(Name:=„ICIS_Auftrag_TASKF“, Type:=dbOpenDynaset)
’ With rs
’ .AddNew
’ .Fields(„TF_Partner_Nr“).Value = Tabelle2.Range(„Q11“)
’ .Fields(„Vorname“).Value = Tabelle2.Range(„Q17“)
’ .Fields(„Name“).Value = Tabelle2.Range(„Q18“)
’ .Fields(„AuftragsDatum“).Value = Tabelle2.Range(„Q19“)
’ .Fields(„Auftraggeber“).Value = Tabelle2.Range(„Q8“)
’ .Fields(„SchadenNr“).Value = Tabelle2.Range(„d6“)
’ .Fields(„Jahr“).Value = Tabelle2.Range(„q9“)
’ .Fields(„Schadentag“).Value = Tabelle2.Range(„I6“)
’ .Fields(„Meldetag“).Value = Tabelle2.Range(„o6“)
’ .Fields(„Schaden“).Value = Tabelle2.Range(„E4“)
’ .Fields(„Reserve“).Value = Tabelle2.Range(„M28“)
’ .Fields(„Ursache“).Value = Tabelle2.Range(„o7“)
’ .Fields(„Sparte“).Value = Tabelle2.Range(„F27“)
’ .Fields(„VertragsNr“).Value = Tabelle2.Range(„F26“)
’ .Fields(„S_Straße“).Value = Tabelle2.Range(„Q20“)
’ .Fields(„S_PLZ“).Value = Tabelle2.Range(„q21“)
’ .Fields(„S_Ort“).Value = Tabelle2.Range(„q22“)
’ .Fields(„Bedingungen“).Value = Tabelle2.Range(„F28“)
’ .Fields(„SB“).Value = Tabelle2.Range(„F32“)
’ .Update
’ MsgBox „(“ & Range(„E4“) & „)“ & " Auftrag (" & Range(„D6“) & „)“ & vbCrLf & „wurde an Dienstleister (“ & Range(„C30“ & ") erfolgreich per Mail verschickt, " & vbCrLf & „und Info im Postkorb hinterlegt !“
’ End With
’ rs.Close
’ db.Close
’ Set rs = Nothing
End Sub
Sub Mail_Weg_Postk()
Dim Adp$, Kp$, Bp$, T1p$, T4p$, Text
Adp = "[email protected]"
Bp = „Schaden Nr.: " & Range(„D6“).Value & " /“ & „/ (“ & Range(„B5“).Value & „)“ & " Auftrag zur Schadenbesichtigung"
T1p = „(“ & Range(„T10“).Value & „)“ & " Auftrag wurde am " & Range(„T11“).Value & " an " & Range(„N30“).Value & " versandt."
T4p = „Auftrag Schaden Nr.: (“ & Range(„D6“).Value & „)“ & " wurde per Mail von " & Range(„C16“).Value & „verschickt !“
MailErstellenp Adp, Kp, Bp, T1p, T4p
’ Datensatzerstellen
End Sub
Sub MailErstellenp(Adpr$, Kopie$, Betrifft$, Text$, Text4$)
Dim sText As String, sText1 As String, sEmpfang As String, sBetrifft As String
Dim session As Object, db As Object, doc As Object, rtobject As Object
Dim rtitem As Object, sKopie As String, AttachMe As Object, AttachMe2 As Object, DerAnhang As Object
Dim user As String, server As String, mailfile As String, sBlindKopie As String
Dim vAn As Variant, vCopy As Variant, vBlind As Variant, sAnhang As String, sAnhang2 As String
Dim strDoc As String
'*** Mail erstellen
'sText = T1 & T4
sText = Text & vbCrLf & vbCrLf & Text4
sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
' sEmpfang = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
sEmpfang = Adpr ' Einträge durch " ; " getrennt
sBetrifft = Betrifft ' die Betreffzeile
' sKopie = Kopie
' sKopie = "[email protected]" ' Einträge durch " ; " getrennt
' sBlindKopie = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
vAn = Split(sEmpfang, " ; ") ' Empfänger Array
sAnhang = Range("D6") & "_Beauftragung_TASKF.pdf"
sAnhang2 = Range("D6") & "_Beauftragung_TASKF.pdf"
If Len(sKopie) > 0 Then vCopy = Split(sKopie, " ; ") 'cc Array
If Len(sBlindKopie) > 0 Then vBlind = Split(sBlindKopie, " ; ") 'bcc Array
Set session = CreateObject("notes.notessession") ' Notes muss gestartet sein
user = session.UserName
server = session.GetEnvironmentString("MailServer", True)
mailfile = session.GetEnvironmentString("MailFile", True)
Set db = session.GETDATABASE(server, mailfile)
Set doc = db.CreateDocument()
doc.Form = "Memo"
doc.SendTo = vAn ' an array
If Len(sKopie) > 0 Then doc.copyto = vCopy 'cc Array
If Len(sBlindKopie) > 0 Then doc.blindcopyto = vBlind 'bcc Array
doc.Subject = sBetrifft ' die Betreffzeile
Set rtitem = doc.CREATERICHTEXTITEM("body")
Call rtitem.APPENDTEXT(sText)
doc.SaveMessageOnSend = True
doc.ReplaceItemValue("ReturnReceipt", "1") = True
doc.PostedDate = Now
'*****************Datei speichern, schliessen und versenden*************
’ Set wkbMappe = Workbooks(Range(„D6“ & „E5“))
’ If Not wkbMappe Is Nothing Then wkbMappe.Save
'strDoc = ActiveWorkbook.Path & „“ & ActiveWorkbook.Name
'Application.Quit
’ **********************************************************************
'If sAnhang <> "" Then
' Set AttachMe = doc.CREATERICHTEXTITEM(strDoc)
' Set DerAnhang = AttachMe.EMBEDOBJECT(1454, "", strDoc)
'End If
'*******************************
Call doc.Send(False)
Aufraeumen:
On Error Resume Next
Set rtitem = Nothing
Set AttachMe = Nothing
Set DerAnhang = Nothing
Set db = Nothing
Set doc = Nothing
Set session = Nothing
Exit Sub
Fehler:
Resume Aufraeumen
End Sub