Der Remote Server ist nicht verfügbar...
28.07.2023 10:26:48
Chris
mit unten stehendem Makro erstelle ich aus Excel heraus Serienbriefe. Hierbei wird für jeden Datensatz eine eigene PDF-Datei erzeugt. Dies funktioniert beim erstem Mal problemlos, beim zweiten Mal erhalte ich die im Betreff genannte Fehlermeldung (Der Remote Server ist nicht verfügbar.), obwohl die ObjektVariablen am Ende zurückgesetzt werden.
Hat jmd. eine Idee, wo der Fehler liegt?
Sub SB
Dim winword, WinDoc As Word.Document, docSerienbrief As Word.Document
Dim sFile As String, sBrief As String
Dim stratenquelle As String
Dim strWordvorlage As String
Dim PDFpath As String
Application.DisplayAlerts = False
strDatenQuelle = Sheets("ADMIN").Range("C2").Text
strWordvorlage = Sheets("ADMIN").Range("C3").Value
PDFpath = Sheets("ADMIN").Range("C1").Text
sFile = strWordvorlage
Set winword = CreateObject("Word.Application")
With winword
.Visible = False
'Vorlagedatei öffnen
Set WinDoc = .Documents.Open(sFile)
With WinDoc
With .MailMerge
'Datenquelle öffnen
.OpenDataSource Name:=strDatenQuelle, _
Connection:="Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & strDatenQuelle & ";" _
& "Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";" _
& "Jet OLEDB:Engine ", _
SQLStatement:="SELECT * FROM `RDSL$`"
'Serienbrief mit allen Daten in neuem Dokument erstellen
With ActiveDocument.MailMerge
.DataSource.ActiveRecord = 1
Do
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
sBrief = PDFpath & "B1-" & UCase(.DataFields("Nachname").Value) & ", " & .DataFields("Vorname").Value & ".pdf"
End With
.Execute Pause:=False
If .DataSource.DataFields("Nachname").Value & "," & .DataSource.DataFields("Vorname").Value > "" Then
ActiveDocument.SaveAs Filename:=sBrief, FileFormat:=wdFormatPDF
End If
ActiveDocument.Close False
If .DataSource.ActiveRecord .DataSource.RecordCount Then
.DataSource.ActiveRecord = wdNextRecord
Else
Exit Do
End If
If .DataSource.ActiveRecord Mod 5 = 0 Then
DoEvents
End If
Loop
End With
End With
End With
End With
winword.Quit savechanges:=False
Set WinDoc = Nothing
Set docSerienbrief = Nothing
Set winword = Nothing
Application.DisplayAlerts = True
End Sub