AW: ...falls das nicht zu heftig ist! Sonst besser...
22.07.2011 15:13:27
HansP
So, dann probier ich das mal..
Private Sub Verzeichnis_Konvertieren_EN()
Dim X_Workbook As String, sPath As String
sPath = ThisWorkbook.Path
LW = ThisWorkbook.Path & "\Datenblätter\"
Dateiname = Dir(LW & "*.xlsx")
While Dateiname ""
X_Workbook = Left(Dateiname, Len(Dateiname) - 5)
Workbooks.Open Filename:=sPath & "\Datenblätter\" & X_Workbook & ".xlsx"
Dim Quelle, Ziel
Quelle = sPath & "\Vorlagen\Vorlage_9001_en.docx"
Ziel = sPath & "\Vorlage_9001_en.docx"
Dim Quelle2, Ziel2
Quelle2 = sPath & "\Titel\Titel_9001_en.docx"
Ziel2 = sPath & "\Titel_9001_en.docx"
FileCopy Quelle, Ziel
FileCopy Quelle2, Ziel2
Dim Quelle3, Ziel3
Quelle3 = sPath & "\Titel_BA\Titel_BA_9001_en.docx"
Ziel3 = sPath & "\Titel_BA_9001_en.docx"
Dim Quelle4, Ziel4
Quelle4 = sPath & "\Titel_BAS\Titel_BAS_9001_en.docx"
Ziel4 = sPath & "\Titel_BAS_9001_en.docx"
FileCopy Quelle3, Ziel3
FileCopy Quelle4, Ziel4
Range("A1:D80").Select
Selection.Copy
Sheets.Add
ActiveWorkbook.Sheets("Tabelle1").Name = "Worktmp1"
ActiveSheet.Paste
Sheets("Worktmp1").Select
Dim myWord As Object
On Error Resume Next
Set myWord = GetObject("Word.Application.14")
If Err.Number 0 Then
Err.Clear
Set myWord = CreateObject("Word.Application.14")
myWord.Visible = True: myWord.WindowState = wdWindowStateMinimize
Else
myWord.Activate
myWord.Visible = True: myWord.WindowState = wdWindowStateMaximize
End If
Windows(X_Workbook).Activate
Sheets("Worktmp1").Select
If Worksheets("Worktmp1").Range("B24").Value = "TM_1234" Then
Worksheets("Worktmp1").Range("B24").Value = "TM_1234"
If Err.Number 0 Then
Err.Clear
Set myWord = CreateObject("Word.Application.14")
myWord.Visible = True: myWord.WindowState = wdWindowStateMinimize
Else
myWord.Activate
myWord.Visible = True: myWord.WindowState = wdWindowStateMaximize
End If
myWord.Application.Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
myWord.ActiveDocument.ApplyQuickStyleSet ("Word 2003")
myWord.ActiveDocument.SaveAs Filename:=sPath & "\Datenblätter\" & "pdf.docx", FileFormat:= _
wdFormatXMLDocument
myWord.Application.Selection.InsertBreak Type:=wdSectionBreakNextPage
If myWord.ActiveWindow.View.SplitSpecial wdPaneNone Then
myWord.ActiveWindow.Panes(2).Close
End If
If myWord.ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow.ActivePane.View. _
Type = wdOutlineView Then
myWord.ActiveWindow.ActivePane.View.Type = wdPrintView
End If
myWord.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
myWord.ActiveWindow.Selection.HeaderFooter.LinkToPrevious = Not Selection.HeaderFooter. _
LinkToPrevious
myWord.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
myWord.Application.Documents.Open (sPath & "\Datenblätter\" & Dateiname & "_9001" & "_T" & " _
.docx")
myWord.Application.Windows(sPath & "\Datenblätter\" & Dateiname & "_9001" & "_T" & ".docx"). _
Activate
myWord.Application.Selection.WholeStory
myWord.Application.Selection.Copy
myWord.Application.Windows("pdf.docx").Activate
myWord.Application.Selection.PasteAndFormat (wdPasteDefault)
myWord.Application.Selection.InsertBreak Type:=wdSectionBreakNextPage
myWord.Application.Documents.Open (sPath & "\Datenblätter\" & Dateiname & "_9001" & "_T_BA" _
& ".docx")
myWord.Application.Windows(sPath & "\Datenblätter\" & Dateiname & "_9001" & "_T_BA" & ". _
docx").Activate
myWord.Application.Selection.WholeStory
myWord.Application.Selection.Copy
myWord.Application.Windows("pdf.docx").Activate
myWord.Application.Selection.PasteAndFormat (wdPasteDefault)
myWord.Application.Selection.InsertBreak Type:=wdSectionBreakNextPage
myWord.Application.Documents.Open (sPath & "\Datenblätter\" & Dateiname & "_9001" & "_T_BAS" _
& ".docx")
myWord.Application.Windows(sPath & "\Datenblätter\" & Dateiname & "_9001" & "_T_BAS" & ". _
docx").Activate
myWord.Application.Selection.WholeStory
myWord.Application.Selection.Copy
myWord.Application.Windows("pdf.docx").Activate
myWord.Application.Selection.PasteAndFormat (wdPasteDefault)
myWord.Application.Selection.InsertBreak Type:=wdSectionBreakNextPage
myWord.Application.Documents.Open (sPath & "\Datenblätter\" & Dateiname & "_9001" & ".docx") _
myWord.Application.Windows(sPath & "\Datenblätter\" & Dateiname & "_9001" & ".docx"). _
Activate
myWord.Application.Selection.WholeStory
myWord.Application.Selection.Copy
myWord.Application.Windows("pdf.docx").Activate
myWord.Application.Selection.PasteAndFormat (wdPasteDefault)
myWord.Application.ActiveWindow.ActivePane.VerticalPercentScrolled = 0
myWord.Application.Selection.HomeKey Unit:=wdStory
myWord.Application.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
myWord.Application.Selection.Delete Unit:=wdCharacter, Count:=1
myWord.Application.Windows("pdf.docx").Activate
myWord.ActiveDocument.ApplyQuickStyleSet ("Word 2003")
myWord.ActiveDocument.ExportAsFixedFormat OutputFileName:=sPath & "\Datenblätter\" & "D" & _
Dateiname & "_" & Dateiname2 & "_EN" & ".pdf", ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False
myWord.Application.Quit (True)
Set myWord = Nothing
Kill sPath & "\Datenblätter\" & "*.docx"
Kill Ziel
Kill Ziel2
Kill Ziel3
Kill Ziel4
Dateiname = Dir
Wend
End Sub
Wie gesagt, die Makros sind identisch. Der Fehler tritt bisher aber nur bei der englischen Version auf. Und auch nur dann, wenn ich automatisch das deutsche und dann das englische Makro ablaufen lasse. Dokumentiere ich Deutsch aus, kommt es zu keinem Fehler.