AW: FileDialog läuft nur einmal
05.05.2018 22:20:10
Ete
Sorry, da hast du Recht. Ich dachte, dass jemand allgemein diesen Bug kennt. ANbei der Code:
Option Explicit
Public actWorkbook As String
Public Datensourcepath As String
Public strZielDatei As String
'_____________________________________
Sub Datenuebertragen()
actWorkbook = ActiveWorkbook.Name
'MsgBox actWorkbook
Datensourcepath = ThisWorkbook.Path
strZielDatei = "Referenztabelle.xlsx"
'Application.ScreenUpdating = False
Dim actTable As String 'Worksheet
Dim sRow As String
Dim strQuelle$
Dim strZiel$
sRow = Selection.row
actTable = ActiveSheet.Name
Workbooks.Open Datensourcepath & "\" & strZielDatei
Workbooks(strZielDatei).Worksheets("Tabelle1").UsedRange.ClearContents
strQuelle = "[" & ThisWorkbook.Name & "]Kinderdaten!10:10"
strZiel = "[" & strZielDatei & "]Tabelle1!1:1"
'kopieren
Range(strQuelle).Copy
Range(strZiel).PasteSpecial (xlPasteValues)
strQuelle = "[" & ThisWorkbook.Name & "]Kinderdaten!" & sRow & ":" & sRow & ""
strZiel = "[" & strZielDatei & "]Tabelle1!2:2"
'kopieren
Range(strQuelle).Copy
Range(strZiel).PasteSpecial (xlPasteValues)
'schliessen und speichern
Workbooks(strZielDatei).Close SaveChanges:=True
MsgBox "Daten wurden kopiert!", vbInformation
'Application.ScreenUpdating = True
Application.SendKeys ("{ESC}")
Call SerienbriefEinzelnPDF
End Sub
'___________________________________________
Sub SerienbriefEinzelnPDF()
Application.DisplayAlerts = True
Dim WordAppl As Object
Dim WordDoc As Object
Dim strDatenQuelle As String
Dim strZiel As String
Dim lAnzZettel As Long
Dim i As Long
Dim strDateiName As String
Dim Datum As String
Dim NameVorlage As String
actWorkbook = ActiveWorkbook.Name
'MsgBox actWorkbook
Datensourcepath = ThisWorkbook.Path
strZielDatei = "Referenztabelle.xlsx"
Datum = Format(Now, "YYMMDD_HHMM")
Dim varDatei As Variant
varDatei = Application.GetOpenFilename()
If varDatei = False Then
MsgBox "Der Benutzer hat abgebrochen.", vbInformation
Exit Sub
Else
MsgBox "Folgende Datei wurde ausgewählt:" & vbCrLf & varDatei
strDateiName = varDatei
End If
'With Application.FileDialog(msoFileDialogOpen)
' .AllowMultiSelect = False
' .InitialFileName = ThisWorkbook.Path & "\Vorlagen\*.do*"
' If .Show = -1 Then
' strDateiName = .SelectedItems(1)
'Else
'Exit Sub
' End If
'End With
MsgBox "Stop"
strDatenQuelle = ThisWorkbook.Path & "\Referenztabelle.xlsx"
Set WordAppl = CreateObject("Word.Application")
With WordAppl
.Visible = True
Set WordDoc = WordAppl.Documents.Open(strDateiName)
With WordDoc
NameVorlage = .Name
With .MailMerge
.OpenDataSource Name:=strDatenQuelle, LinkToSource:=True, Format:=0, SQLStatement:=" _
SELECT * FROM `Tabelle1$`"
.Destination = 0 '= wdSendToNewDocument
.SuppressBlankLines = True
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
strZiel = ThisWorkbook.Path & "\Druck\" & Left(NameVorlage, Len( _
NameVorlage) - 5) & "_" & .DataFields("NameKind")
End With
.Execute Pause:=False
'speichern und schließen des einzelnen Zetteldokuments
With WordAppl
If .Documents.Count > 1 Then
.ActiveDocument.SaveAs Filename:=strZiel & "_" & Datum & ".pdf", _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.ActiveDocument.Close 0 '=wdDoNotSaveChanges
End If
End With
Next i
End With
'Serienbriefstartdatei schließen
.Close 0 '=wdDoNotSaveChanges
End With
'versuche Word zu schließen
.Quit 0
End With
strDateiName = ""
Set WordDoc = Nothing
Set WordAppl = Nothing
End Sub