Scripte zusammenfassen, pers. Anrede 3 Sprachen
Squishy
gibt es eine Möglichkeit diese beiden Scripte (welche funktionieren) zusammenzufassen, sodass beide bzw. ein Script aus dem Word gestartet werden kann?
Grundsätzlich wird ein Serienbrief einzeln als .pdf abgespeichert und danach als Anhang per Mail versendet.
Zudem wäre ich froh wenn mir jemand bei der persönlichen Anrede in 3 Sprachen helfen kann. Gedacht wäre es so, wenn in Zelle Sprache "Deutsch" und in Zelle Anrede "Herr" dann "Sehr geehrter Herr" sonst "Sehr geehrte Frau" danach weiter mit Sprache "Französisch" und zum Schluss noch "Italienisch".
Danke für eure Hilfe.
Private Const Verzeichnis = "C:\TEST" 'Pfad im den die Dateien abgespeichert werden
Private Const Praefix = "" 'Optional eine Zeichenfolge davor
Private Const Schluessel = "Datei" 'Feldname des Felds, welches den Speichername enthält
Sub Serienbrief_pro_Empfänger_abspeichern()
Application.ScreenUpdating = False
With ActiveDocument.MailMerge
If .MainDocumentType = wdNotAMergeDocument Then
MsgBox "Das aktive Dokument ist kein Seriendruckhauptdokument."
Exit Sub
End If
.DataSource.ActiveRecord = wdLastRecord
Anzahl = .DataSource.ActiveRecord
If Anzahl = 0 Then
MsgBox "Es wurden keine Datensätze gefunden."
Exit Sub
End If
flag = False
For Each x In .DataSource.DataFields
If x.Name = Schluessel Then
flag = True
Exit For
End If
Next
If flag = False Then
Q = Chr(34)
MsgBox "Das nominierte Feld " & Q & Schluessel & Q & _
" existiert nicht in der Datenquelle."
Exit Sub
End If
.Destination = wdSendToNewDocument
For i = 1 To Anzahl
.DataSource.ActiveRecord = i
dsname = Verzeichnis & "\" & Praefix & _
.DataSource.DataFields(Schluessel).Value & ".pdf"
.DataSource.FirstRecord = i
.DataSource.LastRecord = i
.Execute
ActiveDocument.Range.Find.Execute FindText:="^b", ReplaceWith:=""
ActiveDocument.SaveAs FileName:=dsname, FileFormat:=wdFormatPDF, AddToRecentFiles:=False
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Next i
.DataSource.FirstRecord = 1 'be smart
Application.ScreenUpdating = True
End With
End Sub
Sub Serienmails_erstellen()
Dim MyOutApp As Object, MyMessage As Object
Dim Zeile As Long, LetzteZeile As Long
Dim Sicherheit As String, Anhang As String
Sicherheit = MsgBox("Sind Sie sicher, dass Sie das Serienmail-Makro starten wollen?", vbYesNo, " _
Sind Sie sicher?") ' Sicherheitsfrage um Marko abzubrechen
If Sicherheit = vbNo Then Exit Sub
LetzteZeile = Range("A65536").End(xlUp).Row 'Ermittelt letzte Zeile
For Zeile = 2 To LetzteZeile 'Erste Daten in der Zeile 2
Anhang = "C:\TEST\" & Cells(Zeile, 14) & ".pdf" 'Pfad der gespeicherten Dateien und Name der _
Datei in Spalte N
If Cells(Zeile, 13).Value = "" Then GoTo Sprungmarke 'Wenn keine E-Mail Addresse in Spalte M _
vorliegt, nächste Zeile
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.To = Cells(Zeile, 13) 'E-Mail Adresse in Spalte M
.Subject = "Betreff" 'Betreff
.Body = "Bla Bla"
.Attachments.Add Anhang 'Beilage
.Display 'Mail wird angezeigt
'.Send Mail wird versendet
End With
Set MyOutApp = Nothing
Set MyMessage = Nothing
Application.Wait (Now + TimeValue("0:00:05"))
Sprungmarke:
Next Zeile
End Sub