• DİKKAT

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

WORD to PDF Macrosu Hk. Soru

M

mtnozd

Katılım
9 Ekim 2016
Mesajlar
9
Excel Vers. ve Dili
2016 / İngilizce
Merhaba,

Daha önce @halit3 Bey'in yazmış olduğu macroyu çalıştırdım öncelikle ellerinize sağlık hocam.

Kod: 
Sub word_pdf_dosyasi_yap()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Liste2 (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
End Sub
 
Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.getfolder(Yol).Files

Uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)

If Uzanti = "doc" Or Uzanti = "docx" Then

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Documents.Open (dosya)
wrdApp.Visible = True
say = CreateObject("Scripting.FileSystemObject").getfolder(Yol).Files.Count + 1
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:=Yol & "\" & say & " " & dosya_adi & ".pdf", ExportFormat:=wdExportFormatPDF

wrdApp.Quit
Set wrdApp = Nothing

End If
Atla:

Next

On Error GoTo sonraki
For Each f In fL.getfolder(Yol).SubFolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Yukarıda yazılan macro'da WORD ile PDF'leri aynı klasör içinde çevirme işlemi yapıyor. Ancak benim yaklaşık 38.000 tane word dosyası çevirmem gerekiyor.

Karışıklık olmaması için de PDF çevirilerini farklı bir klasöre almam için nasıl bir değişiklik yapmam gerekiyor?

Örneğin; WORD dökümanları "c:/word" , çevrim yapılan PDF dökümanlar "c:/pdf" klasöründe olacak.

Yardımcı olabilir misiniz?
Teşekkür ederim.
 
Bu kod dosyanın hemen yanına Word klasörü oluşturuyor ve kayıtları bunun içine yapıyor.

Rich (BB code): 
Sub word_pdf_dosyasi_yap()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Liste2 (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
  
End Sub

Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.getfolder(Yol).Files

Uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)

If Uzanti = "doc" Or Uzanti = "docx" Then

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Documents.Open (dosya)
wrdApp.Visible = True


Klasor = ThisWorkbook.Path & "\Word"
If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If


say = fL.getfolder(Klasor).Files.Count + 1
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:=Klasor & "\" & say & " " & dosya_adi & ".pdf", ExportFormat:=wdExportFormatPDF

wrdApp.Quit
Set wrdApp = Nothing

End If
Atla:

Next

On Error GoTo sonraki
For Each f In fL.getfolder(Yol).SubFolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
@halit3 Teşekkürler hocam elinize sağlık dediğiniz gibi word isimli bir klasör oluşturup içine gönderdi ancak aşağıdaki gibi bir hata ekranı ile karşılaşıyorum sonra çalışmayı durduruyor.

Screenshot_1.jpg
 
Bu hatayı aldığınız da kodlar bölümünde sarı renkli olan bölümün ekren görüntüsünü ekleyiniz.
 
Referanslardan

Microsoft Word 12.0 Object Library
bu olmalı
 
Verdiği hata mesajına göre; dosya bozulmuş olmalı ....

Hata mesajını verdiği anda, mouse'u sarı renkli satırda "dosya" kelimesi üzerine getirip, bekletin. Hataya hangi dosyanın neden olduğunu görebilirsiniz.

Daha sonra, o dosyayı manuel olarak açmayı deneyin..... Dosyanın gerçekten bozulup, bozulmadığını bu şekilde anlayabilirsiniz.

.
 
halit3' Alıntı:
Referanslardan

Microsoft Word 12.0 Object Library
bu olmalı
Genişletmek için tıkla ...


Haluk' Alıntı:
Verdiği hata mesajına göre; dosya bozulmuş olmalı ....

Hata mesajını verdiği anda, mouse'u sarı renkli satırda "dosya" kelimesi üzerine getirip, bekletin. Hataya hangi dosyanın neden olduğunu görebilirsiniz.

Daha sonra, o dosyayı manuel olarak açmayı deneyin..... Dosyanın gerçekten bozulup, bozulmadığını bu şekilde anlayabilirsiniz.

.
Genişletmek için tıkla ...


@halit3 hocam teşekkür ederim desteğin için.

@Haluk hocam sana da teşekkür ederim. Dediğin gibi uyarının hatasına bakınca benim dosya adım aşağıdaki görüleceği üzere normalde metin şeklindeydi ama hata da ~$mtn1.docx gibi bir dosyayı denemeye çalışıyordu. Sanırım daha önce test etmek için oluşturduğum bir dosya belleğinde kaldı. Test ettiğim dosyayı silip temiz bir dosya üzerinde çalışmaya başlayınca hata gitti şu an "işlem tamam" şeklinde program sonlanıyor :)

hata1.jpg hata.jpg
 
Kodları güncelledim

Rich (BB code): 
Sub word_pdf_dosyasi_yap()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Liste2 (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
End Sub
 
Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.getfolder(Yol).Files

Uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)

If "~$" = Mid(dosya.Name, 1, 2) Then GoTo Atla2
If Uzanti = "doc" Or Uzanti = "docx" Then

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Documents.Open (dosya)
wrdApp.Visible = True

Klasor = ThisWorkbook.Path & "\Word"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

say = fL.getfolder(Klasor).Files.Count + 1
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:=Klasor & "\" & dosya_adi & " " & say & ".pdf", ExportFormat:=wdExportFormatPDF

wrdApp.Quit
Set wrdApp = Nothing

End If

Atla2:

Next

On Error GoTo sonraki
For Each f In fL.getfolder(Yol).SubFolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
halit3' Alıntı:
Kodları güncelledim

Rich (BB code): 
Sub word_pdf_dosyasi_yap()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Liste2 (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
   
End Sub

Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.getfolder(Yol).Files

Uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)

If "~$" = Mid(dosya.Name, 1, 2) Then GoTo Atla2
If Uzanti = "doc" Or Uzanti = "docx" Then

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Documents.Open (dosya)
wrdApp.Visible = True

Klasor = ThisWorkbook.Path & "\Word"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

say = fL.getfolder(Klasor).Files.Count + 1
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:=Klasor & "\" & dosya_adi & " " & say & ".pdf", ExportFormat:=wdExportFormatPDF

wrdApp.Quit
Set wrdApp = Nothing

End If

Atla2:

Next

On Error GoTo sonraki
For Each f In fL.getfolder(Yol).SubFolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
Genişletmek için tıkla ...

Hocam konuyu hortlatıyorum gibi olucak ama çok güzel çalışıyor hatta baya bir yol kat ettim.
Ancak şu andaki dosyalarımda save - save as çıkmaya başladı. tek tek hepsine don't save diyorum. o yüzden de kullanamıyorum şu anda.
hata.jpg

Bunun için kod üzerinden mi yoksa program üzerinden mi birşey değiştirmem gerekli acaba?
 
Günaydın herkese,

Bu konuda bilgisi ya da önerisi olan var mı acaba? Tüm dosyalarımda "Save - Don't Save" çıkarttığı için macro da bir işime yaramamaya başladı :(
 
Siz bu kodu mabil uygulamasındamı yapıyorsunuz
 
halit3' Alıntı:
Siz bu kodu mabil uygulamasındamı yapıyorsunuz
Genişletmek için tıkla ...

Hayır hocam, biri 64GB diğer 128GB lık normal server 2008 kurulu 2 sunucu üzerinde Office 2016'da çalıştırıyorum.

Cihazlar service pack 1 yüklü şekilde.

pc.png

Dosyaları "compatibility" modunda açıyor ve o da bu kaydet kaydetme gibi bir ekran çıkarıyor. o yüzden de macroyu kullanamaz oldum.
 
her iki bilgisayarda da aynı hatayımı olıyorsunuz
 
halit3' Alıntı:
her iki bilgisayarda da aynı hatayımı olıyorsunuz
Genişletmek için tıkla ...

Evet hocam, iki bilgisayarda da bu ekran çıkıyor.

Örnek veriyorum; 10 tane word dosyası için çalıştırıyorum bunu. 10 tane pdf oluşturuyor ama arkaplanda word açıp kapatması gerekiyor ya, onları kapatamıyor ve bu save don't save ekranı çıkıyor 10 kere don't save tıklıyorum elimle.

ben bunu 1000 dosya için çalıştırsam 1000 kere elle manuel olarak don't save demem lazım. Bunu otomatikleştirmem gerekiyor :(

isterseniz denediğim word dökümanını da gönderebilirim.
 
sizin word dosyalarında makro varmı
boş iki adet word dosyası oluştur onları bir dene o dosyalarda pdf oluşuyormu

bunları şundan yazıyorum ben deniyorum böyle bir sorun çıkmıyor.
 
Birde bu kodu denermisiniz.

Kod: 
'referanslar
'Microsoft Word 12.0 Object Library


Sub word_pdf_dosyasi_yap()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Liste2 (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
End Sub
 
Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")


For Each dosya In fL.GetFolder(Yol).Files

uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)

If "~$" = Mid(dosya.Name, 1, 2) Then GoTo Atla2
If uzanti = "doc" Or uzanti = "docx" Then
veri = dosya

Dim objWord As Word.Application
Dim docWord As Word.Document

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set docWord = objWord.Documents.Open(Filename:=veri, ReadOnly:=False)

Klasor = ThisWorkbook.Path & "\Word"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

say = fL.GetFolder(Klasor).Files.Count + 1
objWord.ActiveDocument.ExportAsFixedFormat OutputFileName:=Klasor & "\" & dosya_adi & " " & say & ".pdf", ExportFormat:=wdExportFormatPDF

'docWord.Close
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit SaveChanges:=wdSaveChanges


Set docWord = Nothing

End If

Atla2:

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
halit3' Alıntı:
Birde bu kodu denermisiniz.

Kod: 
'referanslar
'Microsoft Word 12.0 Object Library


Sub word_pdf_dosyasi_yap()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Liste2 (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
   
End Sub

Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")


For Each dosya In fL.GetFolder(Yol).Files

uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)

If "~$" = Mid(dosya.Name, 1, 2) Then GoTo Atla2
If uzanti = "doc" Or uzanti = "docx" Then
veri = dosya

Dim objWord As Word.Application
Dim docWord As Word.Document

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set docWord = objWord.Documents.Open(Filename:=veri, ReadOnly:=False)

Klasor = ThisWorkbook.Path & "\Word"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

say = fL.GetFolder(Klasor).Files.Count + 1
objWord.ActiveDocument.ExportAsFixedFormat OutputFileName:=Klasor & "\" & dosya_adi & " " & say & ".pdf", ExportFormat:=wdExportFormatPDF

'docWord.Close
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit SaveChanges:=wdSaveChanges


Set docWord = Nothing

End If

Atla2:

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
Genişletmek için tıkla ...


Mükemmelsiniz hocam ellerinize sağlık :) Şu an süper çalışıyor. Tabi diğer yazdığınız macroya nazaran daha yavaş convert işlemi yapıyor ama o ekranda çıkan "save - don't save" kutucuğu çıkmadan başka bir klasöre convert işlemini yapıyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst