Soft returns macro - vba

How do I modify the following Word macro to convert soft returns to hard returns and process all files in subfolders as well using "new file" as an event trigger?
Sub ConvertReturns()
'This Sub loops through docx files in a folder, opens each file, finds manual line breaks, replaces each with a paragraph return, saves changed file to a new folder, closes original file.
Dim oSourceFolder, oTargetFolder, oDocName As String
Dim oDoc As Document
Dim oRng As Range
'Set paths to folders for original and converted files on user's hard drive.
oSourceFolder = "C:\Users\Administrator\Desktop\Unprocessed\"
oTargetFolder = "C:\Users\Administrator\Desktop\Processed\"
'Get a handle on the first file in the source folder
oFile = Dir(oSourceFolder & "*.doc")
'Continue doing the following steps until there are no more unprocessed files in the source folder
Do While oFile <> ""
'Open the file
Set oDoc = Documents.Open(FileName:=oSourceFolder & oFile)
'Get the name of the document you just opened
oDocName = Left(oDoc.Name, Len(oDoc.Name) - 3)
'Find all manual line breaks and replace them with paragraph markers
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "^l"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
End With
oRng.Find.Execute Replace:=wdReplaceAll
'Save the changed document with the same name but appended with "_Converted" in your target folder
oDoc.SaveAs oTargetFolder & oDocName & "doc"
'Close the original document without saving changes
oDoc.Close SaveChanges:=False
'Get a handle on the next file in your source folder
oFile = Dir
Loop
End Sub

I personally prefer to work with the Scripting.FileSystemObject; it's generally easier to work with than parsing and recombining the output of the VBA Dir function. Add a reference to the Microsoft Scripting Runtime library, via Tools -> References....
I would suggest using the following functions :
Public Function GetFiles(ByVal roots As Variant) As Collection
Select Case TypeName(roots)
Case "String", "Folder"
roots = Array(roots)
End Select
Dim results As New Collection
Dim fso As New Scripting.FileSystemObject
Dim root As Variant
For Each root In roots
AddFilesFromFolder fso.GetFolder(root), results
Next
Set GetFiles = results
End Function
Private Sub AddFilesFromFolder(folder As Scripting.folder, results As Collection)
Dim file As Scripting.file
For Each file In folder.Files
results.Add file
Next
Dim subfolder As Scripting.folder
For Each subfolder In folder.SubFolders
AddFilesFromFolder subfolder, results
Next
End Sub
This takes a path, or a Scripting.Folder object (or an array of either), and returns a collection of File objects for each file in all the subfolders for the passed in folder(s).
Then you can write your code as follows:
Sub ConvertReturns()
'This Sub loops through docx files in a folder recursively, opens each file, finds manual line breaks, replaces each with a paragraph return, saves changed file to a new folder, closes original file.
Dim targetFolder As String
Dim oFile As Scripting.file, oFso As New Scripting.FileSystemObject
Dim oDoc As Document, oRng As Range
Dim fileName As String, fileExtension As String
Dim targetPath As String
'Set paths to folders for original and converted files on user's hard drive.
Const sourceFolder = "C:\Users\Administrator\Desktop\Unprocessed\"
targetFolder = "C:\Users\Administrator\Desktop\Processed\"
'Repeat the following code for each File object in the Collection returned by GetFiles
For Each oFile In GetFiles(sourceFolder)
'This handles any Word Document -- .doc and .docx
If oFile.Type Like "Microsoft Word*" Then
'Open the file
'.Path returns the full path of the file
Set oDoc = Documents.Open(fileName:=oFile.Path)
'Find all manual line breaks and replace them with paragraph markers
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "^l"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
End With
oRng.Find.Execute Replace:=wdReplaceAll
fileName = oFso.GetBaseName(oFile.Name)
fileExtension = oFso.GetExtensionName(oFile.Name)
targetPath = oFso.BuildPath(targetFolder, fileName & "_Converted." & fileExtension)
'Save the changed document with the same name but appended with "_Converted" in your target folder
oDoc.SaveAs targetPath
'Close the original document without saving changes
oDoc.Close SaveChanges:=False
End If
Next
End Sub
References:
Scripting Runtime
FileSystemObject object
GetBaseName method
GetExtensionName method
BuildPath method
File object
Type property
Word object model
Global ActiveDocument property
Application object
Documents property
Documents collection
Open method
Document object
Range method
SaveAs2 method
Close method
Range object
Find method
Find object
Text property
Format, Wrap, Forward, MatchCase properties
Replacement property
Execute method
Replacement object,
Text property
VBA
TypeName function
Array function
Collection object
Add method
Like operator

Related

AppActivate wrd.Name error 5 - trying to Batch replace header image in several MS Word

I need to update a massive number of documents with our new company logo. The task its just to replace the existing header image with a new one. I found an ancient code that should work with older versions of MS Word but it breaks on 365, so I need the help of a kind soul to guide me as I'm illiterate in VBA.
I tried the following code:
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:\Test\*.doc")
Do While (FName <> "")
With wrd
'Change the directory to YOUR folder's path
.Documents.Open ("C:\Test\" & 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
It should open all files on a given directory, delete the header and paste the one held on the clipboard. When I try to run it, I get error '5' on line 5 (AppActivate wrd.Name).
The code you in your question is written to be run from outside Word, probably from Excel.
One thing that you need to figure out is which of the three types of header you are replacing. The code below assumes it is the main header. If you need just the first page header replace wdHeaderFooterPrimary with wdHeaderFooterFirstPage. You can tell which header you need by editing the header in the UI and checking the grey label.
The code you have is not well written and can be simplified as below.
Sub ReplaceEntireHdrXL()
Dim wrd As Word.Application
Set wrd = CreateObject("word.application")
wrd.Visible = True
'Change the directory to YOUR folder's path
Dim FName As String
FName = Dir("C:\Test\*.doc")
Dim doc As Document
Do While (FName <> "")
'Change the directory to YOUR folder's path
Set doc = wrd.Documents.Open("C:\Test\" & FName)
With doc
With .Sections(1).Headers(wdHeaderFooterPrimary).Range
.Paste
'if what you have copied includes a paragpraph mark at the end
'you may need to delete the last para in the header
.Paragraphs.Last.Range.Delete
End With
.Save
.Close
End With
FName = Dir
Loop
Set wrd = Nothing
End Sub
You can simplify things further if you run it from Word instead.
Sub ReplaceEntireHdr()
Dim FName As String
'Change the directory to YOUR folder's path
FName = Dir("C:\Test\*.doc")
Dim doc As Document
Do While (FName <> "")
'Change the directory to YOUR folder's path
Set doc = Documents.Open("C:\Test\" & FName)
With doc
With .Sections(1).Headers(wdHeaderFooterPrimary).Range
.Paste
'if what you have copied includes a paragpraph mark at the end
'you may need to delete the last para in the header
.Paragraphs.Last.Range.Delete
End With
.Save
.Close
End With
FName = Dir
Loop
End Sub

Excel to Word VBA Export - Word Documents Not Being Created

I'm running an Excel to Word Export and I cannot create / save new documents based on the template. Each loop will reopen the word template, replaces the <<>> values in the template, and then moves on the next.
(Background - I have a table in Excel consisting 32 rows and 70 columns. I've created a corresponding word template consisting of values to replace from the excel sheet (for instance, <>). On the run, It exports values based on corresponding tags (for instance, <>) in the Excel sheet to the Word Doc). It seems to be working until it gets to WordDoc.SaveAs Filename
The error I get is
Do you want to save your document as the template name? yes / no
it stops there and does not create templates but only changes the template file.
Can anyone suggest a fix to this?
Sub CreateWordDoc()
Dim BenefitRow, BenefitCol, LastRow As Long
Dim TagName, TagValue, Filename As String
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordContent As Word.Range
On Error Resume Next
With Sheets("VBA Output")
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make visible
LastRow = .Range("A9999").End(xlUp).Row 'Determine last row
For BenefitRow = 4 To 6
Set WordDoc = WordApp.Documents.Open(Filename:=" template name.dotm", ReadOnly:=False) 'Open Template saved as .dotm
For BenefitCol = 1 To 79
TagName = .Cells(3, BenefitCol).Value 'Tag Name
TagValue = .Cells(BenefitRow, BenefitCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll ',Forward:True, Wrap:wdFindContinue
End With
Next BenefitCol
Filename = ThisWorkbookPath & "\" & .Range("E" & BenefitRow).Value & ".docx"
WordDoc.SaveAs Filename
WordDoc.Close
Next BenefitRow
End With
WordApp.Quit
End Sub
The problem (error message) you're seeing comes from opening a template file then wanting to save it as a "plain vanilla" document. This isn't how Word was designed to be used, which is why Word is basically saying, "Are you sure that's what you want to do?"
A template should not be opened unless the purpose is to change the template, itself. In that case, it would be saved again as a template - no message would be displayed.
When creating new documents from a template use the Documents.Add method:
Set WordDoc = WordApp.Documents.Add(Template:=" template name.dotm")
This automatically creates a copy of the template - there's no danger of overwriting the template. And the message mentioned in the question will not appear when the SaveAs method is executed.

Text Replacement in MS Word

In my MS-Word template, my client sends template with an error in the header section, as below,
VERMONT, ROBIN S. Date: 10/21/2017
File No: 312335 DOB: 05/02/1967Claim#: RE155B53452
DOI: 06/21/2017
The error being the ‘Claim#’ coming up right next to the DOB value, while it should come on the next line, as below:
VERMONT, ROBIN S. Date: 10/21/2017
File No: 312335 DOB: 05/02/1967
Claim#: RE155B53452 DOI: 06/21/2017
Also, this error comes up occasionally in some files and not all, so to solve it, I created a word macro, as below:
Sub ShiftClaimNumber2NextLine()
Dim rngStory As Word.Range
Dim lngJunk As Long
'Fix the skipped blank Header/Footer problem as provided by Peter Hewett
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
With rngStory.Find
.text = "Claim#:"
.Replacement.text = "^pClaim#:"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
And I run the above macro through a Group Macro, as below:
Sub ProcessAllDocumentsInFolder()
Dim file
Dim path As String
' Path to folder
path = "D:\Test\"
file = Dir(path & "*.doc")
Do While file <> ""
Documents.Open FileName:=path & file
' Call the macro to run on each file in the folder
Call ShiftClaimNumber2NextLine
' Saves the file
ActiveDocument.Save
ActiveDocument.Close
' set file to next in Dir
file = Dir()
Loop
End Sub
When I run the macro ProcessAllDocumentsInFolder(), for all files with such an error, it shifts the ‘Claim#’ to the next line.
However, the problem is, it also does so for files that do not have such a problem, thereby adding one enter line below the DOB, as below (as depicted by the yellow line):
What changes should I make to my macro ShiftClaimNumber2NextLine() , so that it does not make any change to files which DO NOT HAVE the ‘Claim#’ problem ?
This is a situation best suited to regular expressions see below link for similar issue, refer vba solution
https://superuser.com/questions/846646/is-there-a-way-to-search-for-a-pattern-in-a-ms-word-document
Sub RegexReplace()
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
On Error Resume Next
RegEx.Global = True
RegEx.Pattern = "[0-9]Claim#:"
ActiveDocument.Range = _
RegEx.Replace(ActiveDocument.Range, "\rClaim#:")
End Sub

Copy the contents of a document(s) through FileDialogbox picker, to a new one

With MS_Word 2010 I have been trying to achieve the way to copy the contents(whole) of one file to a new one retrieving the file name of the original and adding it to the new one with the suffix "Copy".
All this process has a reason, since the Original document has only a few editable section and have protection enable (And I cant disable it) but I need to review it with other macro, so with a Copy of the contents in a new document I have been able to apply my whole macro. I also know of the method CopyFile but since this method copy also the characteristic of the original doc (the constrains in edit) I decide not to use it.
Searching around and using the recorder(for the copy actions) i have been able to come with this:
Sub Backup()
Dim DocName As String
Dim DocPath As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path of each selected item. Even though the path is aString, the variable must be a Variant because For Each...Next, routines only work with Variants and Objects.
Dim vrtSelectedItem As Variant
'Use a With...End With block to reference the FileDialog object.
With fd
'Allow the user to select multiple files.
.AllowMultiSelect = True
'Use the Show method to display the File Picker dialog box and return the user's action.
'If the user presses the button...
If .Show = -1 Then
'Step through each string in the FileDialogSelectedItems collection.
For Each vrtSelectedItem In .SelectedItems
On Error Resume Next
'vrtSelectedItem is aString that contains the path of each selected item. You can use any file I/O functions that you want to work with this path.
'MsgBox "Selected item's path: " & vrtSelectedItem
'Retrieve the name of the current doc (later I found out about .Name, .Path, .FullName ...)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
DocName = fso.GetBaseName(vrtSelectedItem)
'MsgBox "Selected item's : " & DocName
'Retrieve the path without the filename/extention
Documents.Open(vrtSelectedItem).Active
DocPath = ActiveDocument.Path
'MsgBox "Selected item's path: " & DocPath
'Copy the content of the current document
'With Documents(DocName)
With ActiveDocument
.WholeStory
.Copy
End With
'Create Backup File with ability to modify it, since the original is protected by password and only few segments are enable to edit
Documents.Add Template:=DocName & "Copy", NewTemplate:=False, DocumentType:=0
'Since Document.Add its suppose to promp as the Active document
'Paste the contents and save
'With Documents(DocName & "Copy")
With ActiveDocument
.PasteAndFormat (wdUseDestinationStylesRecovery)
.SaveAs DocPath
End With
'Documents(DocName & "Copy").Close SaveChanges:=True
Next
'If the user presses Cancel...
Else
End If
End With
'Set the object variable to Nothing.
Set fd = Nothing
End Sub
But as you guess, it doesn't work as desire and don't create the copy neither the new document with the name. So any scope in the right direction will be appreciate.
Thanks in advance for all the answers.
For future reference here is the code improved, based in the Response of #Charlie
Sub Backup()
Dim DocName As String
Dim NewDoc As Document
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path of each selected item. Even though the path is aString, the variable must be a Variant because For Each...Next, routines only work with Variants and Objects.
Dim vrtSelectedItem As Variant
'Use a With...End With block to reference the FileDialog object.
With fd
'Allow the user to select multiple files.
.AllowMultiSelect = True
'Use the Show method to display the File Picker dialog box and return the user's action.
'If the user presses the button...
If .Show = -1 Then
'Step through each string in the FileDialogSelectedItems collection.
For Each vrtSelectedItem In .SelectedItems
On Error Resume Next
'vrtSelectedItem is aString that contains the path of each selected item. You can use any file I/O functions that you want to work with this path.
'MsgBox "Selected item's path: " & vrtSelectedItem
'Retrieve the name of the current doc (later I found out about .Name, .Path, .FullName ...)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
DocName = fso.GetBaseName(vrtSelectedItem)
'MsgBox "Selected item's : " & DocName
'Create Backup File with ability to modify it, since the original is protected by password and only few segments are enable to edit
Set NewDoc = Documents.Add
'Since Document.Add its suppose to promp as the Active document
'Paste the contents and save
With NewDoc
Selection.InsertFile FileName:=vrtSelectedItem, Range:=vbNullString, _
ConfirmConversions:=False, Link:=False, Attachment:=False
.SaveAs FileName:=vrtSelectedItem & "_BACKUP.docx"
.Close
End With
Next
'If the user presses Cancel...
Else
End If
End With
'Set the object variable to Nothing.
Set fd = Nothing
End Sub
I would try creating a new Word doc then using this line to "insert the text from the protected Word doc." It's the same as going to the Insert Ribbon tab -> Object -> Text from File.
Selection.InsertFile FileName:="protected.docx", Range:="", _
ConfirmConversions:=False, Link:=False, Attachment:=False

Use VBS to copy from Notepad to Word

I'm trying to create a script to convert PDF to plain text, then copy the plain text into Word. (We do a lot of reformatting corrupt documents from scratch where I work.) I have a script that's working perfectly except for one thing: when pasting into Word, it doesn't paste the whole file. With longer files, I'm only getting part of the text.
'string to hold file path
Dim strDMM
strDMM = "[path]"
'make this directory if it doesn't exits
On Error Resume Next
MkDir strDMM
On Error GoTo 0
'get the file name to process
Dim TheFile
TheFile = InputBox("What is the file name?" & chr(13) & chr(13) & "(Example: [name].pdf)", "Name of File")
'declare some acrobat variables
Dim AcroXApp
Dim AcroXAVDoc
Dim AcroXPDDoc
'open acrobat
Set AcroXApp = CreateObject("AcroExch.App")
AcroXApp.Hide
'open the document we want
Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
AcroXAVDoc.Open "[path to desktop]" & TheFile, "Acrobat" 'users are instructed to save to the Desktop for ease of access here
'make sure the acrobat window is active
AcroXAVDoc.BringToFront
'I don't know what this does. I copied it from code online.
Set AcroXPDDoc = AcroXAVDoc.GetPDDoc
'activate JavaScript commands w/Acrobat
Dim jsObj
Set jsObj = AcroXPDDoc.GetJSObject
'save the file as plain text
jsObj.SaveAs strDMM & "pdf-plain-text.txt", "com.adobe.acrobat.plain-text"
'close the file and exit acrobat
AcroXAVDoc.Close False
AcroXApp.Hide
AcroXApp.Exit
'declare constants for manipulating the text files
Const ForReading = 1
Const ForWriting = 2
'Create a File System Object
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
'read file and get text
dim objFile
set objFile=objFSO.OpenTextFile( strDMM & TheFile, ForReading)
Dim strText
strText=objFile.ReadAll
'Create a Word Object
Dim objWord
set objWord = CreateObject("Word.Application")
'make Word visible
With objWord
.Visible = True
End With
'Add method used to create a blank document
Dim objDoc
Set objDoc=objWord.Documents.Add()
'create a shorter variable to pass commands to Word
Dim objSelection
set objSelection=objWord.Selection
'type the read text into Word; this is the part that's failing
objSelection.TypeText strText
objFile.Close
I've tried multiple files with the same result. The funny thing is, it pastes the same material from file A each time, but when copying from file B, it pastes a different amount of material. In other words, if A gives me 8 pages of 60 on the first run, I get those same 8 pages each time. File B might give me 14 pages of 60, then it gives me the same 14 pages each time. This only changes if I delete material from the .txt file. If I delete several paragraphs from A, then run the script, I might get 12 pages. Then I get those same 12 every time. But there's no pattern (that I can discern) to predict where it cuts off.
I can't find any EOF characters, and when I read from notepad and write to notepad, the whole thing is copied perfectly. The problem is somewhere in the transfer to Word.
Is there something I'm missing? Is there a limit to the size of a string that Word can write with TypeText? (I would think that if that were the case, I wouldn't get documents of varying length, right? Shouldn't they all stop at n characters if that's the limit?)
I've read about additional libraries that let VBS work with the clipboard, but I'm a total noob and don't know if that's a more elegant solution or how to make it work. I'm also not sure that on my work computer I have the necessary access to install those libraries.
Any help is appreciated!
There is no need to read a file into Word, you can insert a text file from disk
Dim objWord
'Dim objDoc
Set objWord = CreateObject("Word.Application")
'make Word visible
With objWord
.Visible = True
'Add method used to create a blank document
.Documents.Add
.Selection.InsertFile FileNameAndPath
End With
The basic problem, which you hinted at, is that the String data type is limited to 65,400 characters. With an unknown file length, it is better to read in one line at a time and write it to Word. There is a good discussion of something similar here. The following code should help you get where you wan to go:
'read file and get text
dim objFile
set objFile=objFSO.OpenTextFile( strDMM & TheFile, ForReading)
'Don't do this!
'Dim strText
'strText=objFile.ReadAll
'Create a Word Object
Dim objWord
set objWord = CreateObject("Word.Application")
'make Word visible
With objWord
.Visible = True
End With
'Add method used to create a blank document
Dim objDoc
Set objDoc=objWord.Documents.Add()
'create a shorter variable to pass commands to Word
Dim objSelection
set objSelection=objWord.Selection
'Read one line at a time from the text file and
'type that line into Word until the end of the file is reached
Dim strLine
Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
objSelection.TypeText strLine
Loop
objFile.Close
Hope that helps!