I have a Word document with a Macro that is executed daily and converts all Word documents that had been updated within the last 24 hours to PDF. The problem is that it runs on the File Server, that the folder contains about 150'000 files and that the macro takes 7 minutes while occupying more than 45% of the CPU. Usually there won’t be more than 30-40 files that need that conversion to PDF. But off course the macro scans all the content
I noticed that the PDF’s are all created within the first minute so my guess is that “by nature” windows starts in its routines with the most recent files and proceeds towards the oldest.
Using this characteristics, I could probably run this loop 100 times and abort it then.
Any comment is apeciated.
This is the macro:
Sub Loop_through_files()
Dim cDocuments As New Collection
Dim sPath As String, sFilter As String
Dim sCurrentDocName As String, sFullname As String
Dim i As Long
Dim xNewName As String
Dim xIndex As Integer
Set WordObject = CreateObject("Scripting.FileSystemObject")
sPath = "\\XXXXXXXX\XXXXX\Certificates"
sFilter = "*.DOC*"
Set cDocuments = Nothing
sCurrentDocName = Dir(sPath & "\" & sFilter)
Do Until sCurrentDocName = ""
cDocuments.Add Item:=sCurrentDocName
sCurrentDocName = Dir
Loop
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = cDocuments.Count To 1 Step -1 '
sFullname = sPath & "\" & cDocuments(i)
Set f = WordObject.GetFile(sFullname)
If f.DateLastModified > DateAdd("d", -1, Date) Then
xIndex = InStr(cDocuments(i), ".")
xNewName = Left(cDocuments(i), xIndex) + "pdf"
Documents.Open FileName:=sFullname, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
ActiveDocument.ExportAsFixedFormat OutputFileName:=sPath & "\" & xNewName, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges, OriginalFormat:=wdOriginalDocumentFormat
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Related
I have a macro that converts (exports) word documents inside a folder into PDF. The macro works, but WORD keeps on popping up the save dialog, which kills the idea of a batch operation. The command
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
that helped me on other ocasions, does not work for some reason. Any suggestion is welcomed.
Martin
Sub Loop_through_files()
Dim cDocuments As New Collection
Dim sPath As String, sFilter As String
Dim sCurrentDocName As String, sFullname As String
Dim i As Long
Dim xNewName As String
Dim xIndex As Integer
sPath = "C:\Users\xxxxxx\Desktop\ConvertPDF"
sFilter = "*.DOC*"
Set cDocuments = Nothing
sCurrentDocName = Dir(sPath & "\" & sFilter)
Do Until sCurrentDocName = ""
cDocuments.Add Item:=sCurrentDocName
sCurrentDocName = Dir
Loop
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = cDocuments.Count To 1 Step -1 '
sFullname = sPath & "\" & cDocuments(i)
xIndex = InStr(cDocuments(i), ".")
xNewName = Left(cDocuments(i), xIndex) + "pdf"
Documents.Open FileName:=sFullname, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
ActiveDocument.ExportAsFixedFormat OutputFileName:=sPath & "\" & xNewName, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
ActiveWindow.Close
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
In the Close method calls you need to specify the OriginalFormat parameter which is represented by the WdOriginalFormat enumeration:
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges, OriginalFormat:=wdOriginalDocumentFormat
I have a code that I use in Access to save all .docx in a folder as .pdf. The problem is: when there already exists a file .docx as .pdf, the code fails and I don't know why it doesn't save the .docx as .pdf overwriting the pdf previous. How can I do that with my actual code?
My actual code is:
Private Sub Generate_PDFs_Click()
Dim directory As String
Dim fldr As Object
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select folder with Word files to export to PDF"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
directory = .SelectedItems(1)
End With
Dim fso, newFile, Folder, files, folders
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.GetFolder(directory)
Set files = Folder.files
For Each file In files
If file.path Like "*.docx*" Then
newName = Replace(file.path, ".docx", ".pdf")
newName = Replace(newName, ".doc", ".pdf")
'Debug.Print file.Path
Documents.Open FileName:=file.path, _
ConfirmConversions:=False, _
ReadOnly:=False, _
AddToRecentFiles:=False, _
PasswordDocument:="", _
PasswordTemplate:="", _
Revert:=False, _
WritePasswordDocument:="", _
WritePasswordTemplate:="", _
Format:= _
wdOpenFormatAuto, _
XMLTransform:=""
ActiveDocument.ExportAsFixedFormat OutputFileName:=newName, _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:= _
wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, _
From:=1, To:=1, _
Item:=wdExportDocumentContent, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
ActiveDocument.Close
End If
If file.path Like "*.dwg*" Then
MsgBox "Isso ainda não foi feito"
End If
Next
End Sub
Before running save, enter the following line, so Access will not prompt you, to overwrite your file if it already exists,
Application.DisplayAlerts = False
and then after saving to turn the DisplayAlerts back on,
Application.DisplayAlerts = True
Trying to put together a macro that converts a batch of word files into PDFs with file names pulling from table contents within each word file.
I found one macro that converts an open document to PDF with the correct file name and another that converts a batch of selected word files to PDF.
I'm having trouble 'combining' them to get the PDFs to have the correct file name. Any help or suggestions would be greatly appreciated!
Sub Open_File_To_PDF()
Dim StrFilename As String
Dim StrNm As String
Dim StrCat As String
StrNm = Split(ActiveDocument.Tables(1).Cell(5, 1).Range.Text, vbCr)(0)
StrCat = Split(ActiveDocument.Tables(1).Cell(2, 1).Range.Text, vbCr)(0)
StrFilename = StrCat & "_" & StrNm & ".pdf"
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
StrFilename, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, Item:= _
wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
End Sub
Sub ConvertDocmInDirToPDF()
Dim filePath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
filePath = .SelectedItems(1)
End With
If filePath = "" Then Exit Sub
If Right(filePath, 1) <> "\" Then filePath = filePath & "\"
Application.ScreenUpdating = False
Dim currFile As String
currFile = Dir(filePath & "*.docm")
Do While currFile <> ""
Documents.Open (filePath & currFile)
Documents(currFile).ExportAsFixedFormat _
OutputFileName:=filePath & Left(currFile, Len(currFile) - Len(".docm")) & ".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
From:=1, To:=1, Item:=wdExportDocumentContent, IncludeDocProps:=True, _
KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, _
DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False
Documents(currFile).Close
currFile = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Try:
Sub ConvertDocs2PDFs()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
.SaveAs FileName:=Split(.FullName, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
I want to separate my mail merge into separate PDF files (this part is working). But the file names are being saved as a counter i.e. numbers.
Sub AllSectionsToSubDoc()
Dim x As Long
Dim Sections As Long
Dim Doc As Document
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Doc = ActiveDocument
Sections = Doc.Sections.Count
For x = Sections - 1 To 1 Step -1
Doc.Sections(x).Range.Copy
Documents.Add
ActiveDocument.Range.Paste
ActiveDocument.SaveAs (Doc.Path & "\" & x & ".pdf")
ActiveDocument.Close False
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I want to extend this code so that it saves the files with file names which are NOT numbers, but are taken from one of the field codes that I specify.
For example if I specify field code «First_Name» as the file name in my VBA code, and there are 3 names - (John, Peter, Samuel) 3 files should be saved in my destination folder as John.pdf, Peter.pdf, Samuel.pdf
Get the value from the data source, Split between commas, loop through the returned array and save each document individually.
Something like this (I haven't been able to test it).
Dim Value As String
Dim Names As Variant
Dim idx As Long
Value = Doc.DataSource.DataFields("First_Name").Value
Names = Split(Value, ",")
For idx = LBound(Names) To UBound(Names)
ActiveDocument.SaveAs Doc.Path & "\" & Names(idx) & ".pdf"
Next
In the event where the value is a single name (no comma), the Split() function will return an array with a single element.
I managed to find a very simple solution to this. After creating the mail merge, I previewed the results and ran the following macro
ChangeFileOpenDirectory "C:\User\Documents\folder\"
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
" C:\User\Documents\folder\" & ActiveDocument.MailMerge.DataSource.DataFields("Field") & ".pdf", _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForOnScreen, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
and then just loop until the end
I have the following code:
Sub WordtoTxtwLB()
'
' WordtoTxtwLB Macro
'
'
Dim fileName As String
myFileName = ActiveDocument.Name
ActiveDocument.SaveAs2 fileName:= _
"\\FILE\" & myFileName & ".txt", FileFormat:= _
wdFormatText, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, Encoding:=1252, InsertLineBreaks:=True, AllowSubstitutions:=False, _
LineEnding:=wdCRLF, CompatibilityMode:=0
End Sub
I want to loop this sub through all of the word (.doc) files in a directory. I have the following code:
Sub LoopDirectory()
vDirectory = "C:\programs2\test"
vFile = Dir(vDirectory & "\" & "*.*")
Do While vFile <> ""
Documents.Open fileName:=vDirectory & "\" & vFile
ActiveDocument.WordtoTxtwLB
vFile = Dir
Loop
End Sub
But it is not working. How do I get this to work either by altering the current code or using new code?
You don't actually need the WordtoTxtwLB Macro. You can combine both the codes. see this example
Sub LoopDirectory()
Dim vDirectory As String
Dim oDoc As Document
vDirectory = "C:\programs2\test\"
vFile = Dir(vDirectory & "*.*")
Do While vFile <> ""
Set oDoc = Documents.Open(fileName:=vDirectory & vFile)
ActiveDocument.SaveAs2 fileName:="\\FILE\" & oDoc.Name & ".txt", _
FileFormat:=wdFormatText, _
LockComments:=False, _
Password:="", _
AddToRecentFiles:=True, _
WritePassword:="", _
ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, _
SaveFormsData:=False, _
SaveAsAOCELetter:=False, _
Encoding:=1252, _
InsertLineBreaks:=True, _
AllowSubstitutions:=False, _
LineEnding:=wdCRLF, _
CompatibilityMode:=0
oDoc.Close SaveChanges:=False
vFile = Dir
Loop
End Sub
BTW, are you sure you want to use the *.* wildcard? What if there are Autocad files in the folder? Also ActiveDocument.Name will give you the file name with the Extension.
To edit all the word documents in a directory I built this simple subroutine.
The subRoutine loops through the directory and
opens each *.doc file it finds. Then on the open document file it calls
the second subRoutine. After the second subRoutine is finished the document
is saved and then closed.
Sub DoVBRoutineNow()
Dim file
Dim path As String
path = "C:\Documents and Settings\userName\My Documents\myWorkFolder\"
file = Dir(path & "*.doc")
Do While file <> ""
Documents.Open FileName:=path & file
Call secondSubRoutine
ActiveDocument.Save
ActiveDocument.Close
file = Dir()
Loop
End Sub
~~~~~~
Here's my solution. I think it's easy to understand and straight forward for newbies like me that I will post my code here. Because I searched around and the codes I saw were kind of complicated. Let's go.
Sub loopDocxs()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim mySource As Object
Set obj = CreateObject("Scripting.FileSystemObject")
Set mySource = obj.GetFolder("D:\docxs\")
For Each file In mySource.Files 'loop through the directory
If Len(file.Name) > 0 And InStr(1, file.Name, "$") = 0 Then '$ is temp file mask
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
'Word.Application doesn't recognize file here event if it's a word file.
'fortunately we have the file name which we can use.
Set wDoc = wApp.Documents.Open(mySource & "\" & file.Name, , ReadOnly)
'Do your things here which will be a lot of code
wApp.Quit
Set wApp = Nothing
End If
Next file