• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Birden fazla dosyayi emeile tek dosya olarak PDF formatinda ekleme?

  • Konbuyu başlatan Konbuyu başlatan lapot
  • Başlangıç tarihi Başlangıç tarihi
L

lapot

Katılım
4 Temmuz 2006
Mesajlar
239
Arkadaslar
Userformda ,Listview penceresinde bulunan faturalari asagidaki kod ile emaile PDF formatinda ekleyebiliyorum. Listview peneceresindeki her faturanin Excel Sayfa("Multi") de E sutunuda numarasi ve F Sutununda da sistemdeki directory adresi var.

Asagisaki kod E sutundaki fatura numaralarinin karsisindaki F sutununda bulunan directory link'lerini active ediyor ve Word formatinda olan faturalari PDF'e cevirip tek tek emaile ekliyor. Bunlarda hic bir sorun yok.

Bu faturalari bir PDF dosyasi olarak ekleyebilirmiyim?

Saygilar sunuyorum

Private Sub MultipleAttach_Click()

Dim R As Range, fnd As Range, fn As String, fnPDF As String
Dim Ref1 As Long
Dim StrSignature As String
Dim sPath As String
Dim EmailBody As String
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim inv As String, invPDF As String
Dim ws As Worksheet
Dim dic As Object

sPath = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Signature.htm"
If Dir(sPath) <> "" Then
StrSignature = GetSignature(sPath)
Else
StrSignature = ""
End If
On Error Resume Next

Set ws = Worksheets("Multi")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False


'Create e-mail item
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail

Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To Range("E65536").End(3).Row
If Cells(i, "E") <> "" Then dic.Add Cells(i, "E").Value, i
Next i
Ref1 = Join(dic.Keys, " ; ")

.BodyFormat = olFormatHTML
.To = ""
.CC = ""
.BCC = ""
.Subject = "Payment Reminder for " & Ref1
.Body = "Dear Sir" _
& vbCrLf & "" _
& vbCrLf & "Our records is showing that we haven't received payment for " & Ref1 _
& vbCrLf & "" _
& vbCrLf & "I will be grateful if you arrange payment for the attached invoices " _
& vbCrLf & ""


.HTMLBody = strBody & .HTMLBody & StrSignature
'.HTMLBody = "Here is the file you asked for"
For Each rng In Worksheets("Multi").Range("F2", Range("F2").End(xlDown))

invPDF = TempPDF(rng.Value)
MakeWordPDFFile rng.Value, invPDF

.Attachments.Add invPDF

Next
.Display
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

UserForm1.Show
'ThisWorkbook.RefreshAll


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End With
End Sub
 
Video icin tesekkurler fakat o programi sisteme yuklemem icin Admin hakim olmasi lazim bu yok ayrica ben word dosyasini PDF ve cevirp bir emaile birden fazla faturayi ekleyebiliyorum, yapmak isdedigim 10 tane fatura bir PDF dosyasinda olsun hani 10 tane faturayi ayni anda printerde scan yaparsaniz ve email olarak gonderirseniz bir dosy olarak gidiyorya o sekilde yapmak isitiyorum, onlari birlestirmek isitiyorum.
 
Aşağıdaki örnek dosyayı inceleyiniz.

http://s4.dosya.tc/server/kcpsi7/Pdf_Birlestir.zip.html

Tüm dosyalar C:\ bir klasörde bulunmalı.

Klasördeki excel i açın. A sütununda sadece dosya isimlerini yazın.Örnek program 3 dosya içindir.

Birleştirilmiş dosya dosya.pdf olarak kaydedilmektedir.

birleştirmeyi yapan pdftk.exe dosyasıdır.

Aşağıdaki programı kurmadan birleştirme yapılıyor ise sorun yok, çalışmaz ise kurmak gerekecektir.
pdftk_free-2.02-win-setup.exe
 
Son düzenleme:
cok sagol arkadasim dosyayi evdeki bilgisayara indirdim super calisisyor ama isyerinde admin haklarindan dolayi calisirmi bilmiyorum cunku "pdftk.exe" dosyasi olmasi lazim. Deneyip bildiririm. Pazartesi tatil Londrada, muhtemelen Sali gunu denerim.Tabi bendeki path linkleri word documentlerini isaret ediyor onlari pdf formatina cevirip masa ustune save yapmam lazim macroyla, bunun uzerinede calismam lazim.Multiple ekle macrosunda PDF'e cevirip emaile ekliyor, bu makroyla pathlarin word dosyalarini PDF'e cevirip masa uzerine save yaptirmam lazim sonrada tek olarak emaile eklemem lazim.

saygilar
 
Word leri PDF lere çevirme, PDF leri de birleştirme ve birleşmiş dosyayı masaüstüne kaydetme kodları aşağıdaki şekildedir.

Kendi çalışmanıza göre düzenleme yapınız.



Kod: 
Sub menu()
   Call worddenpdfe
   Call pdf_birlestir
End Sub

Sub worddenpdfe()
  Dim worddsoya, pdfdosya As String
  Dim WA As Object

  For i = 1 To 4
    yol = ActiveWorkbook.Path & "\"
    worddosya = yol & i & ".docx"
    pdfdosya = yol & i & ".pdf"
    
    Set WA = CreateObject("Word.Application")
    WA.Documents.Open (worddosya)
    WA.Visible = True
    WA.Application.NormalTemplate.Saved = True
    WA.Application.ActiveDocument.SaveAs pdfdosya, 17
    WA.Documents.Close False
    WA.Quit
  Next i
End Sub


Public Sub pdf_birlestir()
   On Error Resume Next
   yol = ActiveWorkbook.Path
   Kill yol & "\Dosya.pdf"
   masaustu = Environ("USERPROFILE") & "\Desktop"
   
   dosya1 = Cells(1, 1).Value
   dosya2 = Cells(2, 1).Value
   dosya3 = Cells(3, 1).Value
   
   dosya = dosya1 & " " & dosya2 & " " & dosya3

   cmddosya = "pdftk.exe " + dosya + " cat output " & masaustu & "\dosya.pdf"
   komut = "cmd /c cd " & yol & "&&" & cmddosya
   CreateObject("wscript.shell").Run komut, 0, True
   
   If Dir(masaustu & "\dosya.pdf") <> "" Then
     MsgBox ("Dosya oluşturuldu")
   Else
     MsgBox ("Dosya oluşturulamadı")
   End If

End Sub
 
Cok sagol arkadasim kod icin, uzun zamandir bu konuya giremedim. Bendeki word linkleri Sayfa 3 de and F2 sutunundan baslayip asagiya dogru gidiyor. Bu kodu nasil duzenleyebiliriz PDF donusturup sonra birlestirmek icin?
ayrica"pdftk.exe" olmadan birlestirme yapilamazmi, cuku admin hakim yok bilgisayayarda, firma buyuk oldugu icin.
 
Admine GioPSM diye pdf merger programi yuklettim.Bu programi kullanabilirmiyim macroyla
pdftk.exe yerine?
 
Multi sayfasinda F2 den baslayan olan fatura linklerini PDF 'e donusturup asagidaki kod 1 ile emaile ekleyebiliyorum , ayni kodu biraz degistirdim ve Kod2 ile bu faturalari emile ekleme yerine masa uzerine kaydetmeye calistim fakat calismiyor , Yardimci olabilirmisiniz?

Kod 1 :
Private Sub MultipleAttach_Click()

Dim R As Range, fnd As Range, fn As String, fnPDF As String
Dim Ref1, Ref2, Ref3, Ref4 As Long
Dim StrSignature As String
Dim sPath As String
Dim EmailBody As String
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim inv As String, invPDF As String
Dim ws As Worksheet
Dim dic As Object

sPath = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Signature.htm"
If Dir(sPath) <> "" Then
StrSignature = GetSignature(sPath)
Else
StrSignature = ""
End If
On Error Resume Next

Set ws = Worksheets("Multi")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False


'Create e-mail item
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail

Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To Range("E65536").End(3).Row
If Cells(i, "E") <> "" Then dic.Add Cells(i, "E").Value, i
Next i
Ref1 = Join(dic.Keys, " ; ")

.BodyFormat = olFormatHTML
.To = ""
.CC = ""
.BCC = ""
.Subject = "Payment Reminder for " & Ref1
.Body = "Dear Sir" _
& vbCrLf & "" _
& vbCrLf & "Our records is showing that we haven't received payment for " & Ref1 _
& vbCrLf & "" _
& vbCrLf & "I will be grateful if you arrange payment for the attached invoices " _
& vbCrLf & ""


.HTMLBody = strBody & .HTMLBody & StrSignature
'.HTMLBody = "Here is the file you asked for"
For Each Rng In Worksheets("Multi").Range("F2", Range("F2").End(xlDown))

invPDF = TempPDF(Rng.Value)
MakeWordPDFFile Rng.Value, invPDF

.Attachments.Add invPDF

Next
.Display
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

'UserForm1.Show
'ThisWorkbook.RefreshAll


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End With

End Sub



Kod 2 :

Private Sub SaveDesktop_Click()

Dim R As Range, fnd As Range, fn As String, fnPDF As String
Dim inv As String, invPDF As String
Dim ws As Worksheet
Dim dic As Object
Set ws = Worksheets("Multi")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To Range("E65536").End(3).Row
If Cells(i, "E") <> "" Then dic.Add Cells(i, "E").Value, i
Next i
For Each Rng In Worksheets("Multi").Range("F2", Range("F2").End(xlDown))

invPDF = TempPDF(Rng.Value)
MakeWordPDFFile Rng.Value, invPDF

invPDF = ActiveWorkbook.Path
Next
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
 
Bu Kod ile Stun F deki dosya hyperlinklerini calistirip Word 'den PDF cevirip masa uzuerine kaydetmeye calisiyorum fakat calismiyor, birde siz bakarmisiniz neden acaba?

saygilar sunuyorum

Private Sub SaveDesktop_Click()

Dim R As Range, fnd As Range, fn As String, fnPDF As String
Dim inv As String, invPDF As String
Dim ws As Worksheet
Dim dic As Object
Set ws = Worksheets("Multi")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To Range("E65536").End(3).Row
If Cells(i, "E") <> "" Then dic.Add Cells(i, "E").Value, i
Next i
For Each Rng In Worksheets("Multi").Range("F2", Range("F2").End(xlDown))

invPDF = TempPDF(Rng.Value)
MakeWordPDFFile Rng.Value, invPDF

invPDF = ActiveWorkbook.Path
Next
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst