WORD to PDF Macrosu Hk. Soru

[mtnozd]

Merhaba,

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

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.

 

[halit3]

Bu kod dosyanın hemen yanına Word klasörü oluşturuyor ve kayıtları bunun içine yapıyor.

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

 

[mtnozd]

@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.

 

[halit3]

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.

 

[mtnozd]

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.

bu hata ekranına karşılık olarak, aşağıdaki satırı sarı olarak işaretliyor hocam.

 

[halit3]

Referanslardan

Microsoft Word 12.0 Object Library
bu olmalı

 

[Haluk]

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.

.

 

[mtnozd]

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 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

 

[halit3]

Kodları güncelledim

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

 

[mtnozd]

Kodları güncelledim

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

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.


Bunun için kod üzerinden mi yoksa program üzerinden mi birşey değiştirmem gerekli acaba?

 

[mtnozd]

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ı

 

[halit3]

Siz bu kodu mabil uygulamasındamı yapıyorsunuz

 

[mtnozd]

Siz bu kodu mabil uygulamasındamı yapıyorsunuz

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.



Dosyaları "compatibility" modunda açıyor ve o da bu kaydet kaydetme gibi bir ekran çıkarıyor. o yüzden de macroyu kullanamaz oldum.

 

[halit3]

her iki bilgisayarda da aynı hatayımı olıyorsunuz

 

[mtnozd]

her iki bilgisayarda da aynı hatayımı olıyorsunuz

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.

 

[halit3]

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.

 

[halit3]

Birde bu kodu denermisiniz.

'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

 

[serif683]

engelleyen bir program olabilir

 

[mtnozd]

Birde bu kodu denermisiniz.

'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

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.