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
Dosyaları seç PDF yap
-
- Benzer Konular
- Cevaplar
- Görüntüleme
- Son mesaj
-
- 0 Cevaplar
- 1558 Görüntüleme
-
Son mesaj gönderen Beyfendi
-
- 0 Cevaplar
- 1515 Görüntüleme
-
Son mesaj gönderen Gokhan78
-
-
Bordro Tüm Personele Ayrı Ayrı PDF Pusula Oluşturma
gönderen mehmetd » » forum Diğer Excel Paylaşımları - 3 Cevaplar
- 229 Görüntüleme
-
Son mesaj gönderen SNNAY
-