I have many .doc documents located in many subfolders and I would like to covert them to .docx
I was opening each file and saving it but there are too many of them, so I thought there must be a better and a faster way. I found online some VBA code but none seem to work.
First VBA code:
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
Second VBA code:
Sub ConvertBatchToDOCX()
Dim sSourcePath As String
Dim sTargetPath As String
Dim sDocName As String
Dim docCurDoc As Document
Dim sNewDocName As String
' Looking in this path
sSourcePath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
sTargetPath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
' Look for first DOC file
sDocName = Dir(sSourcePath & "*.doc")
Do While sDocName <> ""
' Repeat as long as there are source files
'Only work on files where right-most characters are ".doc"
If Right(sDocName, 4) = ".doc" Then
' Open file
Set docCurDoc = Documents.Open(FileName:=sSourcePath & sDocName)
sNewDocName = Replace(sDocName, ".doc", ".docx")
With docCurDoc
.SaveAs FileName:=sTargetPath & sNewDocName, _
FileFormat:=wdFormatDocumentDefault
.Close SaveChanges:=wdDoNotSaveChanges
End With
End If
' Get next source file name
sDocName = Dir
Loop
MsgBox "Finished"
End Sub
Any help would be much appreciated!
In both routines you have the same small mistake: You miss a Backslash between the path and the filename. Your Dir-Command will see the following command and therefore doesn't find anything:
Dir("H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015*.doc", vbNormal
Either add the backslash at the end of the path definition:
strFolder = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015\"
or put it into the Dir-command:
strFile = Dir(strFolder & "\*.doc", vbNormal)
Related
I believe I have finally come up with a way to extract plain text without line breaks whilst retaining intended carriage returns from PDFs using VBA, Acrobat and Word Combined.
Previous answers using either word or acrobat independently ran into their own issues. Word would occasionally omit text interpreted as images, and Acrobat sometimes would not handle complex structures of PDFs and generate a blank text file.
Having tinkered with word, I realise that it has the option to generate plain text without linebreaks as shown below. Importantly the text generated retains intended carriage returns.
Acrobat does this automatically, too, when generating a plain text file; however, with the issue of unstructured PDFs, I think word is the better bet. And also likely more controllably with VBA.
By combining the two in VBA, I believe I have omitted many of the issues. The text files generated are much more than what I have been after for the past few days. i.e. sentences are not broken with line breaks.
The VBA code below works as follows:
Convert all PDFs contained within a folder to word (using acrobat to ensure no part of the PDF is omitted)
Use words to achieve the conversion to plain text.
Update: 21/12/22 The below code uses FileFormat:=wdFormatText which maybe more straight forward.
Sub ConvertDocumentsToTxt()
'Updated by Extendoffice 20181123
Dim xIndex As Long
Dim xFolder As Variant
Dim xFileStr As String
Dim xFilePath As String
Dim xDlg As FileDialog
Dim xActPath As String
Dim xDoc As Document
Application.ScreenUpdating = False
Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xDlg.Show <> -1 Then Exit Sub
xFolder = xDlg.SelectedItems(1)
xFileStr = Dir(xFolder & "\*.doc")
xActPath = ActiveDocument.Path
While xFileStr <> ""
xFilePath = xFolder & "\" & xFileStr
If xFilePath <> xActPath Then
Set xDoc = Documents.Open(xFilePath, AddToRecentFiles:=False, Visible:=False)
xIndex = InStrRev(xFilePath, ".")
Debug.Print Left(xFilePath, xIndex - 1) & ".txt"
xDoc.SaveAs Left(xFilePath, xIndex - 1) & ".txt", FileFormat:=wdFormatText, AddToRecentFiles:=False
xDoc.Close True
End If
xFileStr = Dir()
Wend
Application.ScreenUpdating = True
End Sub
So far: (Updated now improved - Same as submitted answer)
I have created the following working script in VBA, which achieves these two steps:
References, Acrobat, and Microsoft Scripting Runtime.
Sub LoopThroughFiles()
Dim StrFile As String
Dim pdfPath As String
StrFile = Dir("C:\temp\PDFs\")
fileRoot = "C:\temp\PDFs\"
If Right(fileRoot, 1) <> "\" Then fileRoot = fileRoot & "\" 'ensure terminating \
Do While Len(StrFile) > 0
Debug.Print StrFile
n = StrFile
pdfPath = fileRoot & StrFile
Debug.Print pdfPath
'Convert to WordDoc
success = ConvertPdf2(pdfPath, fileRoot & StrFile & ".doc")
StrFile = Dir
On Error Resume Next
oWd.Quit
'Convert to PlainText
Debug.Print pdfPath & ".doc"
success2 = GetTextFromWord(pdfPath & ".doc", n)
Loop
End Sub
'returns true if conversion was successful (based on whether `Open` succeeded or not)
Function ConvertPdf2(pdfPath As String, textPath As String) As Boolean
Dim AcroXApp As Acrobat.AcroApp
Dim AcroXAVDoc As Acrobat.AcroAVDoc
Dim AcroXPDDoc As Acrobat.AcroPDDoc
Dim jsObj As Object, success As Boolean
Set AcroXApp = CreateObject("AcroExch.App")
Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
success = AcroXAVDoc.Open(pdfPath, "Acrobat") '<<< returns false if fails
If success Then
Application.Wait (Now + TimeValue("0:00:2")) 'Helps PC have some time to go through data, can cause PC to freeze without
Set AcroXPDDoc = AcroXAVDoc.GetPDDoc
Set jsObj = AcroXPDDoc.GetJSObject
jsObj.SaveAs textPath, "com.adobe.acrobat.doc"
AcroXAVDoc.Close False
End If
AcroXApp.Hide
AcroXApp.Exit
ConvertPdf2 = success 'report success/failure
End Function
Function GetTextFromWord(DocStr As String, n)
Dim filePath As String
Dim fso As FileSystemObject
Dim fileStream As TextStream
Dim oWd As Object, oDoc As Object, fileRoot As String
Const wdFormatText As Long = 2, wdCRLF As Long = 0
Set fso = New FileSystemObject
Set oWd = CreateObject("word.application")
fileRoot = "C:\temp\PDFs" 'read this once
If Right(fileRoot, 1) <> "\" Then fileRoot = fileRoot & "\" 'ensure terminating \
Set oDoc = Nothing
On Error Resume Next 'ignore error if no document...
Set oDoc = oWd.Documents.Open(DocStr)
On Error GoTo 0 'stop ignoring errors
Debug.Print n
If Not oDoc Is Nothing Then
filePath = fileRoot & n & ".txt" 'filename
Debug.Print filePath
oDoc.SaveAs2 Filename:=filePath, _
FileFormat:=wdFormatText, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, Encoding:=1252, InsertLineBreaks:=False _
, AllowSubstitutions:=True, LineEnding:=wdCRLF, CompatibilityMode:=0
oDoc.Close False
End If
oWd.Quit
GetTextFromWord = success2
End Function
Please note I am not good at all with VBA; much of this is stitching together answers previously provided and trying to get it to loop through. I am hoping someone with VBA experience can review this and really make it more robust.
It does work, albeit quite slowly, to generate the doc files and then text files:
I hope someone familiar with VBA can help me make this solution more robust.
The files can be downloaded here: https://1drv.ms/u/s!AsrLaUgt0KCLhXtP-jYDd4Z0ujKQ?e=2b6DNg
Add to a PDF folder in temp, and the code should run okay.
Please let me know if you require any more information. I think this is it after a week of questions. Just the code needs tidying up.
Finally, if anyone who comes across this knows of any program that can generate plain text without inserting line breaks but retaining carriage returns, please let me know. Acrobat would be the solution and does work for most cases but has to generate tags on some PDFs, which has failed in my case. I would be very interested in an existing program that can in Batch convert PDFs in this way.
Improved Answer that enables word parameters
ChangeEncoding:=1252 to 65001 for unusual characters(Added below):
Sub LoopThroughFiles()
Dim StrFile As String
Dim pdfPath As String
StrFile = Dir("C:\temp\PDFs\")
fileRoot = "C:\temp\PDFs\"
If Right(fileRoot, 1) <> "\" Then fileRoot = fileRoot & "\" 'ensure terminating \
Do While Len(StrFile) > 0
Debug.Print StrFile
n = StrFile
pdfPath = fileRoot & StrFile
Debug.Print pdfPath
'Convert to WordDoc
success = ConvertPdf2(pdfPath, fileRoot & StrFile & ".doc")
StrFile = Dir
On Error Resume Next
oWd.Quit
'Convert to PlainText
Debug.Print pdfPath & ".doc"
success2 = GetTextFromWord(pdfPath & ".doc", n)
Loop
End Sub
'returns true if conversion was successful (based on whether `Open` succeeded or not)
Function ConvertPdf2(pdfPath As String, textPath As String) As Boolean
Dim AcroXApp As Acrobat.AcroApp
Dim AcroXAVDoc As Acrobat.AcroAVDoc
Dim AcroXPDDoc As Acrobat.AcroPDDoc
Dim jsObj As Object, success As Boolean
Set AcroXApp = CreateObject("AcroExch.App")
Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
success = AcroXAVDoc.Open(pdfPath, "Acrobat") '<<< returns false if fails
If success Then
Application.Wait (Now + TimeValue("0:00:2")) 'Helps PC have some time to go through data, can cause PC to freeze without
Set AcroXPDDoc = AcroXAVDoc.GetPDDoc
Set jsObj = AcroXPDDoc.GetJSObject
jsObj.SaveAs textPath, "com.adobe.acrobat.doc"
AcroXAVDoc.Close False
End If
AcroXApp.Hide
AcroXApp.Exit
ConvertPdf2 = success 'report success/failure
End Function
Function GetTextFromWord(DocStr As String, n)
Dim filePath As String
Dim fso As FileSystemObject
Dim fileStream As TextStream
Dim oWd As Object, oDoc As Object, fileRoot As String
Const wdFormatText As Long = 2, wdCRLF As Long = 0
Set fso = New FileSystemObject
Set oWd = CreateObject("word.application")
fileRoot = "C:\temp\PDFs" 'read this once
If Right(fileRoot, 1) <> "\" Then fileRoot = fileRoot & "\" 'ensure terminating \
Set oDoc = Nothing
On Error Resume Next 'ignore error if no document...
Set oDoc = oWd.Documents.Open(DocStr)
On Error GoTo 0 'stop ignoring errors
Debug.Print n
If Not oDoc Is Nothing Then
filePath = fileRoot & n & ".txt" 'filename
Debug.Print filePath
oDoc.SaveAs2 Filename:=filePath, _
FileFormat:=wdFormatText, LockComments:=False, Password:="", _
AddToRecentFiles:=False, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, Encoding:=65001, InsertLineBreaks:=False _
, AllowSubstitutions:=True, LineEnding:=wdCRLF, CompatibilityMode:=0
oDoc.Close False
End If
oWd.Quit
GetTextFromWord = success2
End Function
Try using below:
strTemp = Replace(FromString, vbCr, " ")
strTemp = Replace(strTemp, vbLf, " ")
strTemp = Replace(strTemp, vbNewline," ")
I use the free tool xpf reader to convert a pdf.
I have a folder which has a bunch of .xls files, of which only those which have the KEY Word " CITIES " are of interest to me. I need to open those files and collect some information and I am facing some issues.
Sub getTheExecSummary()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
myPath = "C:\Users\Morpheus\Documents\Projects\Files"
myExtension = "*.xls" 'How to add the keyword?'
myFile = Dir(myPath & myExtension)
Do While Len(myFile) > 0
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Debug.Print (myFile)
Debug.Print (wb.Name)
ActiveSheet.Range("A1").Value = wb.Name
'Get next file name
myFile = Dir
Loop
End Sub
I did write a few Debug.Print statements none of which seem to work. I want to for now print only those workbooks which have the keyword ' CITIES ' in their name.
I think that you want the Instr function.
If Instr(wb.Name, "CITIES") > 0 then .....
You might want to use "CITIES " or " CITIES " to exclude any unintentional uses of those letters, depending on how the filename is setup
Use the wildcard to identify the missing letters: *CITIES*.xls or *CITIES*.xls* if you're expecting xlsx, xlsm, etc.
Sub Test()
Dim colFiles As Collection
Dim vItem As Variant
Dim wrkBk As Workbook
Dim sPath As String
Set colFiles = New Collection
sPath = "C:\Users\Morpheus\Documents\Projects\Files\"
'you could use:
'sPath = Environ("UserProfile") & "\Documents\Projects\Files\"
EnumerateFiles sPath, "*CITIES*.xls", colFiles
For Each vItem In colFiles
Set wrkBk = Workbooks.Open(vItem)
wrkBk.Worksheets("Sheet1").Range("A1") = wrkBk.Name
Next vItem
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
Sub ReplaceEntireHdr()
Dim wrd As Word.Application
Set wrd = CreateObject("word.application")
wrd.Visible = True
AppActivate wrd.Name
'Change the directory to YOUR folder's path
fName = Dir("C:\Users\user1\Desktop\A\*.doc")
Do While (fName <> "")
With wrd
'Change the directory to YOUR folder's path
.Documents.Open ("C:\Users\user1\Desktop\A\" & fName)
If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
.ActiveWindow.View.Type = wdPrintView
End If
.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
.Selection.WholeStory
.Selection.Paste
.ActiveDocument.Save
.ActiveDocument.Close
End With
fName = Dir
Loop
Set wrd = Nothing
End Sub
I use this vba code to replace all the headers, of all the word documents in a folder 'A'. However if there is any subfolder in the parent folder 'A' with word documents, the vba code skips those documents. Could anyone please tell me how to include the word documents in the subfolders as well? Perhaps by making some changes in the code or any other vba code which can do the same job.
Thanks in advance.
In order to pick up the folders (directories) you need to specify the vbDirectory attribute. By default, Dir only "sees" things that match vbNormal.
Here's an example that picks up both files and sub-directories. The GetAttr function checks whether the file attribute is vbDirectory. If it's not, then it's a file.
What you can do is save the directory paths in an array, then loop that to get the files in the sub-directories.
Sub GetFilesandSubDir()
Dim sPath As String, sPattern As String
Dim sSearch As String, sFile As String
Dim sPathSub As String, sSearchSub As String
Dim aSubDirs As Variant, i As Long
sPattern = "*.*"
sPath = "C:\Test\"
sSearch = sPath & sPattern
sFile = Dir(sPath, vbNormal + vbDirectory)
aSubDirs = TestDirWithSubFolders(sPath, sPattern, sSearch, sFile)
For i = LBound(aSubDirs) To UBound(aSubDirs)
Debug.Print "Directory: " & aSubDirs(i)
sPathSub = sPath & aSubDirs(i) & "\"
sSearchSub = sPathSub & sPattern
sFile = Dir(sPathSub, vbNormal + vbDirectory)
TestDirWithSubFolders sPathSub, sPattern, sSearchSub, sFile
Next
End Sub
Function TestDirWithSubFolders(sPath As String, sPattern As String, _
sSearch As String, sFile As String) As Variant
Dim aSubDirs() As Variant, i As Long
i = 0
Do While sFile <> ""
If GetAttr(sPath & sFile) = vbDirectory Then
'Debug.Print "Directory: " & sFile
ReDim Preserve aSubDirs(i)
aSubDirs(i) = sFile
i = i + 1
Else
Debug.Print "File: " & sFile
End If
sFile = Dir
Loop
TestDirWithSubFolders = aSubDirs
End Function
I would like to open a Word doc, paste data from my Excel file and then save that Word document.
Opening Word and pasting the data works fine, but it doesn't save the file due to a problem with the line "ChDir "C:\My Documents\".
What am I missing here?
Sub macro()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
WordApp.Activate
Set WordDoc = WordApp.Documents.Add
Range("A1:C33").Copy
WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _Placement:=wdInLine, DisplayAsIcon:=False
WordDoc.PageSetup.LeftMargin = CentimetersToPoints(1.5)
WordDoc.PageSetup.TopMargin = CentimetersToPoints(1.4)
WordDoc.PageSetup.BottomMargin = CentimetersToPoints(1.5)
ChDir "C:\My Documents\Test"
ActiveDocument.SaveAs "Archief" & Format(Now, "yyyymmdd") & ".docx"
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
It would be easier to create a variable to include both the path and the name of the file, like this :
Dim FileFullName As String
FileFullName = Environ("userprofile") & "\My Documents\Test" & "\" & "Archief" & Format(Now, "yyyymmdd") & ".docx"
ActiveDocument.SaveAs FileFullName
Try this:
Dim FileName2 As String
Set appWrd = CreateObject("Word.Application")
appWrd.DisplayAlerts = False
FileName2 = Document.Path & "\" & ".docx"
appWrd.ActiveDocument.SaveAs FileName:=FileName2
[Using MS Word 2010]
I have a macro that converts a Word document from docx format to txt format. However there are some documents that stop during conversion with the following notification: "The document may contain text content that will be lost upon conversion to the chosen encoding. To preserve this content , click No to exit this dialog box,and then choose another encoding that supports the languages in this document.
Do you want to continue saving the document? Yes/No"
Of course I want to continue to save the document as txt so I have to click the Yes button. I am converting hundreds of documents (docx) to text and want the macro to intercept this message and tell Word 'Yes" without my intervention. Can anyone tell me the VBA code needed to accomplish this and where in my macro does it need to go? I am a complete novice to VBA. I found the following VBA code on the Internet and it works fine except for what I just indicated about the Word message. Here is the code:
Sub ChangDocsToTxtOrRTForHTML()
'with export to PDF in word 2007
Dim fs As Object
Dim oFolder As Object
Dim tFolder As Object
Dim oFile As Object
Dim strDocName As String
Dim intPos As Integer
Dim locFolder As String
Dim fileType As String
On Error Resume Next
locFolder = InputBox("Enter the folder path do DOCs", "File Conversion", "C:\myDocs")
Select Case Application.Version
Case Is < 12
Do
fileType = UCase(InputBox("Change DOC to TXT, RTF, HTML", "File Conversion", "TXT"))
Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML")
Case Is >= 12
Do
fileType = UCase(InputBox("Change DOC to TXT, RTF, HTML, or PDF(2007+ only)", "File Conversion", "TXT"))
Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML" Or fileType = "PDF")
End Select
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set oFolder = fs.GetFolder(locFolder)
Set tFolder = fs.CreateFolder(locFolder & "Converted")
Set tFolder = fs.GetFolder(locFolder & "Converted")
For Each oFile In oFolder.Files
Dim d As Document
Set d = Application.Documents.Open(oFile.Path)
strDocName = ActiveDocument.Name
intPos = InStrRev(strDocName, ".")
strDocName = Left(strDocName, intPos - 1)
ChangeFileOpenDirectory tFolder
Select Case fileType
Case Is = "TXT"
strDocName = strDocName & ".txt"
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatText
Case Is = "RTF"
strDocName = strDocName & ".rtf"
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatRTF
Case Is = "HTML"
strDocName = strDocName & ".html"
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatHTML
Case Is = "PDF"
strDocName = strDocName & ".pdf"
'*** Word 2007 users - remove the apostrophe at the start of the next line ***
'ActiveDocument.ExportAsFixedFormat OutputFileName:=strDocName, ExportFormat:=wdExportFormatPDF
End Select
d.Close
ChangeFileOpenDirectory oFolder
Next oFile
Application.ScreenUpdating = True
End Sub
Sub ConvertFiles()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.txt", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _
Format:=wdOpenFormatEncodedText, Encoding:=msoEncodingUTF8, _
AddToRecentFiles:=False, Visible:=False)
wdDoc.SaveAs2 FileName:=strFolder & "\" & Replace(strFile, ".txt", ".docx"), _
Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
wdDoc.Close SaveChanges:=False
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
Thank you for your help.
ntman2
For text files, Word is able to use different encoding schemes for saved-as files that can avoid generating this warnings. Try:
ActiveDocument.SaveAs _
FileName:=strDocName, _
Fileformat:=wdFormatText, _
Encoding:=msoEncodingUnicodeLittleEndian
instead of:
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatText