Dosyaları seç PDF yap

[1903emre]

Merhaba,

Aşağıdaki kod, word belgeleri pdf yapıyor, word belgeleri klasör içerisinde karışık olduğu için, word belgeleri sırayla kodlarda aşağıdaki değişiklik yapabilir miyiz

aşağıdaki gibi sırayla pdf oluşturabilir miyiz

Ocak 2023
Şubat 2023
Mart 2023
1.geçici belgesi
Nisan 2023
Mayıs 2023
Haziran 2023
2.geçici belgesi
Temmuz 2023
Ağustost 2023
Eylül 2023
3.geçici belgesi
Ekim 2023
Kasım 2023
Aralık 2023

Kullanılan kod

Sub MergeDocuments()
Dim strFolder As String, strFile As String
Dim DocSrc As Document, DocTgt As Document
Dim strDocNm As String, Rng As Range, HdFt As HeaderFooter

Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set DocTgt = ActiveDocument
strDocNm = DocTgt.FullName
strFile = Dir(strFolder & "\*.doc")

While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set DocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With DocTgt
Set Rng = .Range.Characters.Last

For Each HdFt In .Sections.Last.Headers
HdFt.LinkToPrevious = False
HdFt.Range.Text = vbNullString
Next
For Each HdFt In .Sections.Last.Footers
HdFt.LinkToPrevious = False
HdFt.Range.Text = vbNullString
Next

For Each HdFt In .Sections(.Sections.Count - 0).Headers
With HdFt.Range
.FormattedText = DocSrc.Sections.Last.Headers(HdFt.Index).Range.FormattedText
.Characters.Last.Delete
End With
Next

For Each HdFt In .Sections(.Sections.Count - 0).Footers
With HdFt.Range
.FormattedText = DocSrc.Sections.Last.Footers(HdFt.Index).Range.FormattedText
.Characters.Last.Delete
End With
Next

With Rng
.Collapse wdCollapseEnd
Call LayoutTransfer(DocSrc, DocTgt)
.FormattedText = DocSrc.Range.FormattedText
End With

End With
Selection.EndKey Unit:=wdStory
Selection.Range.InsertBreak Type:=wdSectionBreakNextPage

DocSrc.Close False
End If
strFile = Dir()
Wend
Selection.Delete
DocTgt.ExportAsFixedFormat OutputFileName:= _
strFolder & "\BirlestirilmisBelgeler.pdf" _
, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=False, UseISO19005_1:=False

Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.DisplayAlerts = wdAlertsAll
Application.ScreenUpdating = True

MsgBox "Belgeler birleştirildi"
End Sub

Sub LayoutTransfer(DocSrc As Document, DocTgt As Document)
Dim sPageHght As Single, sPageWdth As Single
Dim sHeaderDist As Single, sFooterDist As Single
Dim sTMargin As Single, sBMargin As Single
Dim sLMargin As Single, sRMargin As Single
Dim sGutter As Single, sGutterPos As Single
Dim lPaperSize As Long, lGutterStyle As Long
Dim lMirrorMargins As Long, lVerticalAlignment As Long
Dim lScnStart As Long, lScnDir As Long
Dim lOddEvenHdFt As Long, lDiffFirstHdFt As Long
Dim bTwoPagesOnOne As Boolean, bBkFldPrnt As Boolean
Dim bBkFldPrnShts As Boolean, bBkFldRevPrnt As Boolean
Dim bOrientation As Boolean

With DocSrc.Sections.First.PageSetup
lPaperSize = .PaperSize
lGutterStyle = .GutterStyle
bOrientation = .Orientation
lMirrorMargins = .MirrorMargins
lScnStart = .SectionStart
lScnDir = .SectionDirection
lOddEvenHdFt = .OddAndEvenPagesHeaderFooter
lDiffFirstHdFt = .DifferentFirstPageHeaderFooter
lVerticalAlignment = .VerticalAlignment
sPageHght = .PageHeight
sPageWdth = .PageWidth
sTMargin = .TopMargin
sBMargin = .BottomMargin
sLMargin = .LeftMargin
sRMargin = .RightMargin
sGutter = .Gutter
sGutterPos = .GutterPos
sHeaderDist = .HeaderDistance
sFooterDist = .FooterDistance
bTwoPagesOnOne = .TwoPagesOnOne
bBkFldPrnt = .BookFoldPrinting
bBkFldPrnShts = .BookFoldPrintingSheets
bBkFldRevPrnt = .BookFoldRevPrinting
End With

With DocTgt.Sections.Last.PageSetup
.GutterStyle = lGutterStyle
.MirrorMargins = lMirrorMargins
.SectionStart = lScnStart
.SectionDirection = lScnDir
.OddAndEvenPagesHeaderFooter = lOddEvenHdFt
.DifferentFirstPageHeaderFooter = lDiffFirstHdFt
.VerticalAlignment = lVerticalAlignment
.PageHeight = sPageHght
.PageWidth = sPageWdth
.TopMargin = sTMargin
.BottomMargin = sBMargin
.LeftMargin = sLMargin
.RightMargin = sRMargin
.Gutter = sGutter
.GutterPos = sGutterPos
.HeaderDistance = sHeaderDist
.FooterDistance = sFooterDist
.TwoPagesOnOne = bTwoPagesOnOne
.BookFoldPrinting = bBkFldPrnt
.BookFoldPrintingSheets = bBkFldPrnShts
.BookFoldRevPrinting = bBkFldRevPrnt
.PaperSize = lPaperSize
.Orientation = bOrientation
End With
End Sub
Function GetFolder() As String
Dim Klasor As Object
GetFolder = ""
Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", 0)

If (Not Klasor Is Nothing) Then GetFolder = Klasor.Items.Item.Path
Set Klasor = Nothing
End Function