I've come here for plenty of advice on how to develop VBScript and VBA applications using Excel, but now I've been faced with a new challenge: develop a VBScript/VBA application for Word.
I know, in Excel, if I wanted to type "my name" in cell B3, I would type this:
Range("B3").Value = "my name"
I need to be able to locate where a name and address for a formal letter would be entered, as well as today's date, and my initials as a signature.
I thought I might be able to find VBScript/VBA programming for Word on the internet like I did for Excel, but it seems like working with Word is not as popular. If anyone has any snippets to get me started, or a really good link to a site on the internet where I can do the coding myself, it would be greatly appreciated.
UPDATE
Here is the code I'm working with at the moment:
Public Sub WordVbaDemo()
Dim doc As Document: Set doc = ActiveDocument ' Or any other document
DateText = doc.Range(doc.Paragraphs(1).Range.End - 20, doc.Paragraphs(1).Range.End - 18).Text
End Sub`
I need the code to work for a formal letter where the date is right-justified:
Date: November 7th, 2016
The code I have above will copy the date text after "Date: ". The original template doesn't have a prefilled date. If I enter one, the "Member: " field looks offset like this:
Date: November 7th, 2016
Member:
I'm looking for a way to enter text without upsetting the alignment.
UPDATE 2
I forgot to mention this has to work as an external script. This means, if I were to open NotePad and create a script that would fill out a letter in a Word document, that is how it should work. I do apologize for this...got ahead of myself and forgot that detail.
UPDATE 3
I'm using the following code derived from code I use to find any open Internet Explorer windows. I know IE and Word are two different things, but I was hoping I could use Shell to find the Word doc and be able to manipulate the content.
Dim WinDoc, Window, TitleFound
Dim WShell, objShell
Function Check_Document()
On Error Resume Next
Set WShell = CreateObject("WScript.Shell")
Set objShell = CreateObject("Shell.Application")
On Error GoTo 0
Window = "non-member template.docx" 'Tried this without the .docx and failed
TitleFound = False
For Each WinDoc In objShell.Windows()
If Err.Number = 0 Then
If InStr(WinDoc.Document.Title, (Window)) Then
Set objWord = WinDoc
TitleFound = True
Exit For
End If
End If
Next
If TitleFound = False Then
MsgBox "Word doc not found"
Else
MsgBox "Found Word doc!!"
End If
End Function
I was in a similar boat about 6 months ago. I had done VBA in Excel, but was asked to do some more in Word. The thing about Word VBA is that there are far fewer reasons to need to automate a Word document than an Excel document. From what I've gathered, most situations involve creating legal documents.
I've come a long way and I do have a number of sites bookmarked that I'll dig further into for you.. but this one is a quickstart to using VBA in Word.
http://word.mvps.org/faqs/MacrosVBA/VBABasicsIn15Mins.htm
But one pointer: consider if the document layout is going to be structured or not.(It wasn't clear to me in your question). If the layout is going to be structured, where you know exactly where everything is going, you might want to use bookmarks. Otherwise, you may consider the paragraphs method as indicated by z32a7ul.
My project uses UserForms as input. It's been a real challenge at times, but by using Userforms with Bookmarks, I'm able to allow the user to navigate back and forth in the userForms as well as re-run the macro (assuming they have not deleted required bookmarks).
Of course, take this with a grain of salt since I'm still learning as well. For what it's worth, I've also had the added challenge of making this all work on the Mac platform.
As a starting point:
Public Sub WordVbaDemo()
Dim doc As Document: Set doc = ActiveDocument ' Or any other document
' doc.Paragraphs(2).Range.Text = "Error if the document is empty (there is no second paragraph)."
doc.Paragraphs(1).Range.Text = "First paragraph overwritten." & vbCrLf
doc.Paragraphs(2).Range.Text = "Now I can write to Paragraph 2." & vbCrLf
doc.Paragraphs.Add(doc.Paragraphs(2).Range).Range.Text = "Inserted between Paragraph 1 and 2." & vbCrLf
doc.Range(doc.Paragraphs(3).Range.End - 3, doc.Paragraphs(3).Range.End - 2).Font.StrikeThrough = True
doc.Range(doc.Paragraphs(3).Range.End - 2, doc.Paragraphs(3).Range.End - 2).Text = 3
doc.Range(doc.Paragraphs(3).Range.End - 3, doc.Paragraphs(3).Range.End - 2).Font.StrikeThrough = False
With doc.Tables.Add(doc.Range(doc.Range.End - 1), 2, 2)
.Cell(1, 1).Range.Text = "Header1"
.Cell(1, 2).Range.Text = "Header2"
.Cell(2, 1).Range.Text = "Value1"
.Cell(2, 2).Range.Text = "Value2"
Dim varBorder As Variant: For Each varBorder In Array(wdBorderTop, wdBorderBottom, wdBorderLeft, wdBorderRight, wdBorderVertical, wdBorderHorizontal)
.Borders(varBorder).LineStyle = wdLineStyleSingle
Next varBorder
.Rows(1).Shading.BackgroundPatternColor = RGB(123, 45, 67)
.Rows(1).Range.Font.Color = wdColorLime
End With
End Sub
First of all, I want to thank everyone who replied. You helped guide me to my solution. Below is the code I came up with to locate where a name and address for a formal letter would be entered, as well as today's date, and my initials as a signature.
Function Check_Document()
On Error Resume Next
Set objWord = CreateObject("Word.Application")
On Error GoTo 0
objWord.Visible = True
Set objDoc = objWord.Documents.Open("C:\Users\lpeder6\Desktop\myDoc.docx")
Set objRange = objDoc.Bookmarks("TodaysDate").Range
objRange.Text = "November 11th, 2016"
Set objRange = objDoc.Bookmarks("Name").Range
objRange.Text = "John Smith"
Set objRange = objDoc.Bookmarks("Address").Range
objRange.Text = "123 N. Anywhere Ave."
Set objRange = objDoc.Bookmarks("City").Range
objRange.Text = "Northwoods" & ", "
Set objRange = objDoc.Bookmarks("State").Range
objRange.Text = "MN"
Set objRange = objDoc.Bookmarks("Zip").Range
objRange.Text = "55555"
Set objRange = objDoc.Bookmarks("Init").Range
objRange.Text = "JS"
End Function
The bookmarks are preset within the document so the code has something to look for. Anything within these fields gets replace with the objRange.Text. Variables could be used to store information if this was external coding and the variables would contain data from arguments sending the data.
I hope this code helps others as much as it helped me. Thanks again to everyone who offered me ideas that got me here.
Related
i have following problem. Im currently creating a Macro that gets every font thats been used in a Word document. Afterwards it checks, if this font is even installed and changes the font into predefined fonts. (As the Microsoft auto-font-change in Word is pretty bad and changes my fonts into Comic Sans (no joke ...).
Everything works as intended except for one thing.
This here is the code i am using to exchange every occurence of the found
font in the document:
For i = 0 To UBound(missingFont)
For Each oCharacter In ActiveDocument.Range.Characters
If oCharacter.Font.name = missingFont(i) Then
oCharacter.Font.name = fontToUse
If InStr(missingFont(i), "bold") Then
oCharacter.Font.Bold = True
End If
If InStr(missingFont(i), "italic") Then
oCharacter.Font.Italic = True
End If
End If
Next oCharacter
Next i
So basically im checking every Character in my document and change it if needed. Now this only works for Characters that are not inside of textfields, the header or footer. How can i check every, EVERY, character inside of the Document?
First i've tried to use ActiveDocument.Range.Paragraphs instead of ActiveDocument.Range.Characters. I've also tried using the macro given here: http://www.vbaexpress.com/forum/showthread.php?55726-find-replace-fonts-macro but couldnt get this to work at all.
It's not clear what is meant by "textfield" as that could be any of five or six different things in Word...
But there is a way to access almost everything (excluding ActiveX controls) in a Word document by looping all StoryRanges. A StoryRange includes the main body of the document, headers, footers, footnotes, text ranges in Shapes, etc.
The following code sample demonstrates how to loop all the "Stories" in a document. I've put the code provided in the question in a separate procedure that's called from the "Stories" loop. (Note that I am not able to test, not having access to either the documents or relevant portions of code used in the question.)
Sub ProcessAllStories()
Dim doc as Word.Document
Dim missingFont as Variant
Dim myStoryRange as Word.StoryRange
'Define missingFont
Set doc = ActiveDocument
For Each myStoryRange In doc.StoryRanges
CheckFonts myStoryRange, missingFont
Do While Not (myStoryRange.NextStoryRange Is Nothing)
Set myStoryRange = myStoryRange.NextStoryRange
CheckFonts myStoryRange, missingFont
Loop
Next myStoryRange
End Sub
Sub CheckFonts(rng as Word.Range, missingFont as Variant)
Dim oCharacter as Word.Range
For i = 0 To UBound(missingFont)
For Each oCharacter In rng.Characters
If oCharacter.Font.name = missingFont(i) Then
oCharacter.Font.name = fontToUse
If InStr(missingFont(i), "bold") Then
oCharacter.Font.Bold = True
End If
If InStr(missingFont(i), "italic") Then
oCharacter.Font.Italic = True
End If
End If
Next oCharacter
Next i
End Sub
I hope my first post will be OK and not offend (I've tried to follow the guide and done a lot of searching).
I've modified the below code from Greg Maxey (https://gregmaxey.com/word_tip_pages/word_fields.html) to update links in my Word document to an Excel workbook. It seems to be the most used code for this purpose. The reason I changed his code was to try to do away with the need to have a counter variable like i, and using a For i = 1 to .Fields.Count Then... Next i structure.
When I run it as is, it gets stuck in a loop only updating the first field in the Word document. To see this, I put in the Debug.Print wrdField.Index line. It repeatedly outputs 1, so it is not moving to the Next wrdField as I expect (the code actually just used Next, but it's the same result if I use Next wrdField).
When I comment out .AutoUpdate = False, it works properly:
Public Sub UpdateExternalLinksToCurrentFolder()
Dim wrdDocument As Word.Document
Dim wrdField As Word.Field
Dim strCurrentLinkedWorkbookPath, strNewLinkedWorkbookPath As String
Dim strCurrentLinkedWorkbookName, strNewLinkedWorkbookName As String
Dim strCurrentLinkedWorkbookFullName, strNewLinkedWorkbookFullName As String
Dim strThisDocumentPath As String
'On Error GoTo ErrorHandler_UpdateExternalLinksToCurrentFolder
Application.ScreenUpdating = False
Set wrdDocument = ActiveDocument
strThisDocumentPath = wrdDocument.Path & Application.PathSeparator
strNewLinkedWorkbookPath = strThisDocumentPath
With wrdDocument
For Each wrdField In .Fields
With wrdField
If .Type = wdFieldLink Then
With .LinkFormat
Debug.Print wrdField.Index
strCurrentLinkedWorkbookPath = .SourcePath & Application.PathSeparator
strCurrentLinkedWorkbookName = .SourceName
strNewLinkedWorkbookName = strCurrentLinkedWorkbookName
strNewLinkedWorkbookFullName = strNewLinkedWorkbookPath & strNewLinkedWorkbookName
.AutoUpdate = False
End With
.Code.Text = VBA.Replace(.Code.Text, Replace(strCurrentLinkedWorkbookPath, "\", "\\"), Replace(strNewLinkedWorkbookPath, "\", "\\"))
End If
End With
Next
End With
Set wrdDocument = Nothing
Application.ScreenUpdating = True
Exit Sub
Can anyone tell my why it's behaving this way? When I set .AutoUpdate = False, am I changing something about the link field or doing something to the Word document that causes the .wrdField.Index to reset to 1? I can't find anything online documenting this behavior and it's driving me nuts.
Behind the scenes, what's happening is that Word recreates the content and the field. The orginal linked content is removed and new content inserted. So that essentially destroys the field and recreates it. A user won't notice this, but VBA does.
When dealing with a loop situation that uses an index and the looped items are being removed, it's therefore customary to loop backwards (from the end of the document to the beginning). Which cannot be done with For...Each.
In MS Word, you can create hyperlinks to a "Place in this document" so that a link takes you someplace else in the same Word file. However, if you change headers or move things around these links will sometimes break. I want to write some VBA to check for broken links.
With VBA, you can list each hyperlink subaddress using the code below:
Sub CheckLinks()
Set doc = ActiveDocument
Dim i
For i = 1 To doc.Hyperlinks.Count
Debug.Print doc.Hyperlinks(i).SubAddress
Next
End Sub
The output from the code above also matches what is shown in the field codes for the hyperlink.
However, I'm not really clear on how to verify if the SubAddress is correct. For example, an excerpt from the program output shows this:
_Find_a_Staff_1
_Edit_Organization_Settings_2
_Set_the_Staff
_Find_a_Staff_1
But there's no obvious way to tell what the "correct" suffix should be for a given heading. Any thoughts on how to check if these are valid?
Is there a way to get the list of all valid subaddresses for the headings in the document?
The code below will list the hyperlinks where the corresponding bookmark does not exist in the document. (Note that it only detects missing links, not links that go to the wrong place.)
Sub CheckLinks()
Dim doc As Document
Set doc = ActiveDocument
Dim i, j
Dim found As Boolean
For i = 1 To doc.Hyperlinks.Count
found = False
For j = 1 To doc.Bookmarks.Count
If doc.Range.Bookmarks(j).Name = doc.Hyperlinks(i).SubAddress Then
found = True
End If
Next
If found = False Then
Debug.Print doc.Hyperlinks(i).SubAddress
End If
Next
End Sub
Disclaimer: It's been a few years since I worked (a lot) with VBA, so this might be an issue caused by confusing myself with what is essentially a very different language from what I usually deal with.
So; I've got a workbook (Excel 2010) with multiple sheets (20+), most of whom are multi-page. To make things easier when printing everything, I want to add some sheet-specific headers with amongst others the name of the sheet, number of pages and so on.
I've written a tiny function that should (in theory) do this for me by iterating over all the sheets setting the header. However, for some reason it only works if the header is empty; if it already has a value it refuses to overwrite for some unknown reason.
Dim sheetIndex, numsheets As Integer
sheetIndex = 1
numsheets = Sheets.Count
' Loop through each sheet, but don't set any of them to active
While sheetIndex <= numsheets
Dim sheetname, role, labeltext As String
sheetname = Sheets(sheetIndex).name
role = GetRole(mode)
labeltext = "Some text - " & sheetname & " - " & role
With Sheets(sheetIndex).PageSetup
.LeftHeader = labeltext
.CenterHeader = ""
.RightHeader = "Page &[Page] / &[Pages]"
.LeftFooter = "&[Date] - &[Time]"
.CenterFooter = ""
.RightFooter = "Page &P / &N"
End With
sheetIndex = sheetIndex + 1
Wend
I found a solution that seems to work for replacing text. For whatever reason, in the macro, you need to include the header/footer format character codes in order for it to work properly.
This code worked to replace existing header text with new information:
Sub test()
Dim sht As Worksheet
Set sht = Worksheets(1)
sht.PageSetup.LeftHeader = "&L left text"
sht.PageSetup.CenterHeader = "&C center Text"
sht.PageSetup.RightHeader = "&R right text"
End Sub
Without the &L, &C, and &R codes before the text, I could not get it to work.
Some interesting behavior I found is that if you use the following code:
.CenterHeader = "&L some text"
it will actually put the some text in the LeftHeader position. This led me to believe that the formatting codes were very important.
The line Application.PrintCommunication = False (which is added by the macro recorder) before doing PageSetup screws up the formating via VBA.
If your code has got this line in it, try removing it. That solved my problem with setting the header and footer via VBA.
I've read StackOverflow for years and this is the first time I've actually been able to post a solution ... hope it helps someone!! Also, you need to remember, I am a CPA not a programmer ;-)
I am reading some values from the ActiveSheet to populate the header. The application is a tax election that will be sent with a tax return so it must have the taxpayer's name and social security number at the top.
Sub PrintElection()
' Print preview the MTM Election
If Range("Tax_Year").Value = Range("First_MTM_year").Value Then
ActiveSheet.PageSetup.LeftHeader = Format(Worksheets("Election").Range("Taxpayer_Name").Value)
ActiveSheet.PageSetup.RightHeader = Format(Worksheets("Election").Range("Taxpayer_SSN").Value)
ActiveWindow.SelectedSheets.PrintPreview
Else
MsgBox "The 'Effective For Tax Year' date must EQUAL the 'First MTM year' date", vbOKOnly, "Check Years"
Sheets("Roadmap").Select
Range("First_MTM_year").Select
End If
End Sub
It checks to see if the Mark-to-Market election year is the same as the election form then formats the election page.
I split the sheet print setup into 2 loops. First loop with Application.PrintCommunication = False I run the non-header/footer setup. I then set Application.PrintCommunication = True and run the header/footer setup in a second loop. Appears to run faster than in XL2003, and applies the header/footer correctly. Until MS fixes this bug, that works fine for me.
I'm currently writing up a macro which compares the contents of a word document against text dictionary file. It highlights all the matches so that the person can make appropriate changes. I'm a little new to macros so I used something similar I found online as a guide as well as my general coding knowhow but I don't know all the methods and objects that I need to.
I have set it up to open a common dialog to choose a word file to compare (the dictionary file is hard coded because I don't want people accidentally choosing one as it could potentially be used by a lot of people)
For each line in the dictionary file, the macro uses the hithighlight method to highlight any occurences of that word in the file. I had to put spaces around the word to make sure only individual words were done since the dictionary contained many acronyms.
The issue is I therefore had to pad the document with spaces at the start and end so that the first and last words are also checked, I'm not sure how to do this though. I've done some searching and I've seen a few things about using different selections but I don't know if there's a clone method for selections and I'm sure if I set another selection as equal to mine it'd just copy the address to the object which would make it pointless.
this is the code I have:
Documents(ActiveDocument.FullName).Close SaveChanges:=wdDoNotSaveChanges
'Values for objFSO
Const ForReading = 1
Const ColourYellow = 65535
Dim doc As Document
Dim DocRange As Range
'allows us to change the document in use
Set ObjCD = CreateObject("UserAccounts.CommonDialog")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
'Relevant path to the Dictionary txt file, change this to point to the dictionary list if different to this
DicFilePath = "O:\IPS\PDU\KIS\Intranet\consistency-with-styleguide-project\styleguidelist.txt"
'Set the parameters for the Common Dialog
ObjCD.Filter = "Word Documents|*.docx" 'Filter only docx files
ObjCD.FilterIndex = 3
ObjCD.InitialDir = "" 'Set the initial path for the Common Dialog to the same folder as the script
'Display the File open dialog
InitFSO = ObjCD.ShowOpen
If InitFSO = False Then
'No file was selected so Error
MsgBox ("No file was selected")
Else
'ScanFilePath = the full path and filename if the file
ScanFilePath = ObjCD.FileName
Set doc = Documents.Open(ScanFilePath) 'store the document we want to check as doc
Set objDicFile = objFSO.OpenTextFile(DicFilePath, ForReading) 'open the dictionary file
With doc
MatchFound = False 'initially have no matches found as haven't searched yet
Set DocRange = .Range 'this represents the entire document
DicWordCount = 0
DocRange.InsertAfter (Space(1))
DocRange.InsertBefore (Space(1))
'do this to pad the start and end with spaces to allow matches for the first and last word
'this is done as it's easier than having it look for start and end of file markers and still only find
'whole words
'Loop though each word in the dictionary and check if that word exists in the word doc
Do While objDicFile.AtEndOfStream <> True
'reset so EACH word in dictionary is checked for
DicWordFound = False
'Read the next word from the dictionary
DicWord = objDicFile.ReadLine
DicWord = Space(1) & DicWord & Space(1) 'add a space to both sides to find whole words only
DicWordFound = DocRange.Find.HitHighlight(DicWord, ColourYellow)
'is true if it was found at least once, else false. If any are found they are highlighted in yellow
If DicWordFound Then
MatchFound = True 'MatchFound if used to check if any match was found for any words, only false if none are found
End If
Loop
'this is done to remove the superfluous space at the end.
End With
If MatchFound Then
'If a Match is found
'Display OK message
MsgBox ("Complete: MATCH FOUND!" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Matches are highlighted in yellow.")
Else
'If a Match is NOT found
MsgBox ("No Match")
End If
End If
if someone knows how I could remove the padding I added once I'm done searching that would be really helpful. Alternatively, if someone could suggest a more efficient way it would be greatly appreciated. (for instance, I'm sure there should be a way to check for whole words only when searching but I don't know it as I'm new to macros)
Also if someone knows for sure if the same functionality is replicated in word 97-2003 using the same methods and objects let me know, that way I can just extend it to .doc files without any extra word.
Thanks for your time.
You can try to record macros, this can help finding objects or method when you can't choose which is the right one.
In your case, you could use the .MatchWholeWord property of the Find object (http://msdn.microsoft.com/en-us/library/bb226067.aspx) :
DicWordFound = DocRange.Find.HitHighlight(DicWord, ColourYellow, MatchWholeWord = True)
Could not check it right here though.
Hope that helps,
Regards,
Max