Macro'da Kişiler İle İlgili Topluca PDF Çıktıları Oluşturulması
Aşağıdaki prosedür, Excel'de her bir satırda ve bu satıların kolonlarındaki bilgileri istenilen formatta düzenleyip birer PDF dosyası oluşturmaktadır.
Dosya Yolu klasöründeki fotoğrafları, Excel dosyasındaki ilgili kolonlara ve PDF dosyasına kopyalamaktadır.
------------------------------------------------------------------------------------------------------------------------
Sub CreateOutputsInPDF()
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
DosyaYolu = Sheets("Parametreler").Range("B1")
DosyaUzantisi = "jpg"
Application.ScreenUpdating = True
For Each Shape In ActiveSheet.Shapes
If Shape.Name <> "Rectangle 1" Then
Shape.Delete
End If
Next
Columns(4).ColumnWidth = Sheets("Parametreler").Range("B2") 'Fotoğraf kolonu genişliği
SonSatirNo = Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To SonSatirNo
Rows(r).RowHeight = Sheets("Parametreler").Range("B3")
DosyaAdi = Range("A" & r)
DosyaTumBilgileri = DosyaYolu & DosyaAdi & "." & DosyaUzantisi
If File_Exists(DosyaTumBilgileri) Then
ActiveSheet.Pictures.Insert(DosyaTumBilgileri).Select
With Selection
.Left = Range("D" & r).Left
.Top = Range("D" & r).Top
.ShapeRange.Height = 250#
.ShapeRange.Width = 120#
End With
End If
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
wdApp.Selection.TypeParagraph
wdApp.Selection.Font.Bold = False
wdApp.Selection.Font.Size = 12
DosyaAdi = Range("A" & r)
DosyaTumBilgileri = DosyaYolu & DosyaAdi & "." & DosyaUzantisi
If File_Exists(DosyaTumBilgileri) Then
wdDoc.Content.InlineShapes.AddPicture (DosyaTumBilgileri)
End If
wdApp.Selection.TypeText Text:="Adı Soyadı: "
wdApp.Selection.TypeText Text:=Range("A" & r) & vbCrLf
wdApp.Selection.TypeText Text:="Doğum Yeri: " & Range("B" & r) & vbCrLf
wdApp.Selection.TypeText Text:="Doğum Tarihi: " & Range("C" & r) & vbCrLf
wdApp.Selection.TypeText Text:=Sheets("Parametreler").Range("B4") & vbCrLf
wdApp.Selection.TypeText Text:=Range("E1") & ": " & Range("E" & r) & vbCrLf
wdApp.Selection.TypeText Text:=Range("F1") & ": " & Range("F" & r) & vbCrLf
wdApp.Selection.TypeText Text:=Range("G1") & ": " & Range("G" & r) & vbCrLf
wdApp.Selection.TypeText Text:=Range("H1") & ": " & Range("H" & r) & vbCrLf
wdApp.Selection.TypeText Text:=Sheets("Parametreler").Range("D5")
wdDoc.PageSetup.PaperSize = wdPaperA3
wdDoc.PageSetup.Orientation = wdOrientLandscape
wdDoc.ExportAsFixedFormat OutputFileName:=Range("A" & r) & ".pdf", ExportFormat:=wdExportFormatPDF, openafterexport:=False
wdDoc.Close wdDoNotSaveChanges
wdApp.Visible = False
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Next r
Range("A1").Select
End Sub
------------------------------------------------------------------------------------------------------------------------
Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean
On Error Resume Next
If sPathName <> "" Then
If IsMissing(Directory) Or Directory = False Then
File_Exists = (Dir$(sPathName) <> "")
Else
File_Exists = (Dir$(sPathName, vbDirectory) <> "")
End If
End If
End Function
------------------------------------------------------------------------------------------------------------------------
Yukarıdaki Veriler sayfasında kişilerin bilgileri yazılmaktadır. Çıktı oluşturan prosedür bu kolonlara göre ayarlanmıştır. Soru hücrelerine istenen başlıklar ve altındaki cevap hücrelerine ilgili karşılıklar girilmelidir.
Aşağıdaki Parametreler sayfasındaki D5 hücresinde istenilen metin yazılmalıdır. B4 hücresine ilgili form başlığı girilmelidir. B1 hücresine fotoğrafların bulunduğu klasörün yolu yazılır.
Otomatik Oluşturulan PDF Dosyaları
Oluşturulan PDF Dosyalardan Birinin İçeriği