Run-time error re "remote server machine" on 2nd run - excel

I have already reviewed a couple of similar posts here, here, here (including referenced link) and here in careful detail, and not found anything that helped.
My script starts in an Excel construction estimate and outputs a proposal draft in Word. The general structure of the program is in three parts:
It pulls the data from the active worksheet (lines 1-226), then
It queries the user for some final needed bits of info via a userform (lines 227-265), then
It opens a letterhead template in Word and dumps everything into it (lines 266-763).
The first time I run the script from the Excel estimate, it executes flawlessly, all the way through to saving the Word document. But if I close that generated Word document and click the "Draft proposal" button again, it gets to a very specific line, not far into the Word portion of the program, and gives me an error, every time. That error is,
"Run-time error '462': The remote server machine does not exist or is unavailable."
Here is the script, starting at the beginning of the Word portion. It breaks at the line where we give our "$TBD" price, right-justified, at the end of trailing dots.
I used a macro to generate this little block of code. I have attempted to fix this bug by simplifying the code here. I used to have unnecessary lines wDoc.DefaultTabStop = InchesToPoints(0.5) and sel.ParagraphFormat.TabStops.ClearAll and it used to break at those lines, but I deleted both of them, and the program still breaks right at the same spot.
'open the Word document with the appropriate template, bind worksheet & doc together,
'activate the window (bring to front), and move cursor to the end of the document
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Add(Template:="C:\Users\" & MyUserName & "\"
'The rest of the filepath is included here, but I'm omitting it for security purposes, ending in "Letterhead.dotm")
wApp.Visible = True
wApp.Activate
Dim sel As Word.Selection
Set sel = wDoc.Application.Selection
sel.EndKey (wdStory)
'create date and address block
sel.InsertDateTime DateTimeFormat:="MMMM dd, yyyy", InsertAsField:=False
sel.TypeParagraph
sel.TypeParagraph
sel.TypeText Text:=ContactName
sel.TypeText Text:=Chr(11)
sel.Font.Bold = wdToggle
sel.TypeText Text:=GCName
sel.TypeParagraph
sel.TypeParagraph
sel.TypeText "Reference: " & vbTab
sel.TypeText Text:=JobName
sel.Font.Bold = wdToggle
sel.TypeParagraph
sel.TypeParagraph
'create the introductory matter to the proposal
sel.TypeText "We are pleased to offer our proposal for the electrical portion of work " & _
"at " & JobAddress & ". Work is based upon " & ArchitectName & " " & PlanType & _
" drawings, dated " & PlansDated & "."
sel.TypeParagraph
sel.TypeParagraph
'make the line of dots before TBD, copy-pasting from a macro
sel.ParagraphFormat.TabStops.Add Position:=InchesToPoints(6.67), Alignment:=wdAlignTabRight, _
Leader:=wdTabLeaderDots 'This is the two-line statement where it breaks.
Oddly, if I delete the offending statement, it gets a little further but then breaks at another random line a little ways down, the ".NumberPosition" property definition within the myNLT With block:
'write the price line, and then erase the single-use tab stop we just set up
sel.Font.Bold = wdToggle
sel.TypeText "We will perform this work for" & vbTab & "$TBD"
sel.Font.Bold = wdToggle
sel.TypeParagraph
sel.TypeParagraph
sel.ParagraphFormat.TabStops.ClearAll
'introduce the itemized SOW
sel.Font.Bold = wdToggle
sel.Font.Underline = wdUnderlineSingle
sel.TypeText "Scope of work to include the following:"
sel.TypeParagraph
sel.Font.Underline = wdUnderlineNone
sel.Font.Bold = wdToggle
'set up itemized list, copy-pasting from a macro, list starts at 1
'establish myNLT as the numbered list template
Dim myNLT As ListTemplate
Set myNLT = wApp.ListGalleries(wdNumberGallery).ListTemplates(1)
With myNLT.ListLevels(1)
.NumberFormat = "%1."
.TrailingCharacter = wdTrailingTab
.NumberStyle = wdListNumberStyleArabic
.NumberPosition = InchesToPoints(0.25) 'If I delete the line indicated
'in the previous block of code, then this is the next place it breaks.
.Alignment = wdListLevelAlignLeft
.TextPosition = InchesToPoints(0.5)
.ResetOnHigher = 0
.StartAt = 1
.LinkedStyle = ""
End With
I have tried On Error Resume Next and I've tried even adding, as "Next," an Application.Wait for two seconds followed by a repetition of the TabStops.Add, but this does nothing but mess up my formatting.
I also tried changing sel.ParagraphFormat.Tabstops.Add to Word.Selection.ParagraphFormat.TabStops.Add - also didn't work.
Following a suggestion in comments also did not work: If I remove everything after .Add, I get
Compile error: Argument not optional.
If I then add back in the first argument, Position:=InchesToPoints(6.67) and leave off Alignment and Leader, then the error comes back.

Related

VBA generates Error on Mac but not Windows

This VBA code tracks the activity of PowerPoint slides and store the record in an Excel worksheet, saved on my local drive (same folder as the slides):
Dim slideShowRunning As Boolean
Dim counter As Integer
Dim st As Dat
Dim i As Integer
Dim sttime As Date
Dim oxlapp As Object
Dim oxlwb As Object
Dim oxlws As Object
Dim edtime As Date
Sub SlideShowBegin(ByVal Wn As SlideShowWindow)
st = Date
sttime = Time
counter = 0
Debug.Print " works;1 "
Set oxlapp = CreateObject("Excel.Application")
Debug.Print " works; 2"
oxlapp.Visible = False
Debug.Print " works; 3"
Set oxlwb = oxlapp.Workbooks.Open(ActivePresentation.Path & "\" & "record.xlsx")
Debug.Print " works; 4"
Set oxlws = oxlwb.Sheets("TimeRecord")
Debug.Print " works; 5"
i = oxlws.Range("A99919").End(-4162).Row
oxlws.Range("A1").Offset(i, 0).Value = st
oxlws.Range("A1").Offset(i, 1).Value = sttime
Debug.Print " works; 6"
End Sub
Public Sub OnSlideShowPageChange(ByVal Wn As SlideShowWindow)
If TypeName(slideShowRunning) = "Empty" Or slideShowRunning = False Then
slideShowRunning = True
SlideShowBegin Wn
End If
End Sub
Public Sub OnSlideShowTerminate(ByVal Wn As SlideShowWindow)
Name = Application.ActivePresentation.Name
slideShowRunning = False
edtime = Time
Debug.Print " works; 7"
ivalue = DateDiff("s", sttime, edtime)
Debug.Print ivalue
oxlws.Range("A1").Offset(i, 2).Value = edtime
oxlws.Range("A1").Offset(i, 3).Value = ivalue
oxlws.Range("A1").Offset(i, 4).Value = Name
Debug.Print " works; 9"
oxlapp.DisplayAlerts = False
Debug.Print " works; 10"
oxlwb.Save
Debug.Print " works; 11"
oxlapp.Visible = True
Debug.Print " works; 12"
oxlapp.DisplayAlerts = True
Debug.Print " works; 13"
End Sub
Note:
The code stores the PowerPoint slide Name along with slide opening
time and slide closing time.
The details are stores in Excel Sheet.
I have many slides all with same code. The code is working fine in Windows.
The code won't work when I run it on MAC.
I know there are few changes that need to be done to make it work on Mac but can't figure out what. Any help would be much appreciated.
(Hijacking AlexG's explanation)
From Wikipedia:
A path is a string of characters used to uniquely identify a location in a directory structure. It is composed by following the directory tree hierarchy in which components, separated by a delimiting character, represent each directory. The delimiting character is most commonly the slash (/), the backslash character (\), or colon (:), though some operating systems may use a different delimiter.
For example,
Classic Mac OS used : as a directory separator (eg., Macintosh HD:Documents:Letter)
Current macOS uses / as a directory separator (eg., /home/user/docs/Letter.txt)
Windows can use either \ or / as a directory separator (eg., C:\user\docs\Letter.txt)
Rather than trying to remember all the different symbols, there's a VBA property called Application.PathSeparator, which returns the path separator for the current operating system.
So, try changing your code from:
Set oxlwb = oxlapp.Workbooks.Open(ActivePresentation.Path & "\" & "record.xlsx")
...to:
Set oxlwb = oxlapp.Workbooks.Open(ActivePresentation.Path & Application.PathSeparator & "record.xlsx")
...and maybe that will solve your problem.
If not, you'll need to provide more specific information about what error you're getting and where.
I can't test it (and you'll find very little support for Excel on Mac) since not very many people use Excel on Mac — especially VBA. (Personally, the last time I touched a Macintosh was ~1986.)
There are several differences between Excel for Mac and Excel for Windows. You can read more about them here, perhaps starting with this explanation.

Inserting shapes gets progressively slower

I make entomological specimen labels that come with an embedded QR code. Museum curators can scan the QR codes of a series of specimens in the same group and manipulate data.
The QR code images are inserted as "shapes" (I believe--they respond to shape commands in the macro), generated via VBA code by Jiri Gabriel, with editing by Jonas Heidelberg (https://github.com/JonasHeidelberg/barcode-vba-macro-only).
The macro takes data, populates cells with strings and values (i.e., what gets printed on the human-readable part of the individual labels). When all of the printed text is inserted, the macro iteratively generates one QR code image at a time and places each generated image next to the corresponding human-readable label.
The macro is quick to generate and insert the first few QR code images then gets progressively slower. I presume because Excel is not built to handle a large number of high-resolution images on the same spreadsheet. My sheet design accommodates 220 individual QR code images, but it takes nearly 10 minutes to populate the spreadsheet with 50 QR code images (it takes less than 30 seconds to populate 10 QR code images, so the slowdown is appreciable).
I have tried:
Disable screen updating - does not seem to improve the processing speed
Set calculation to manual - does not seem to improve the processing speed
After generating each QR code image, hide the image by using the following code, and then at the very end, turn all the images visible - seems to help a little bit but not nearly sufficient to make the macro usable at scale.
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Visible = False
I looked for solutions to see if the QR code image shapes can be merged into one shape, because after all, wouldn't it be easier to manage a single shape than 200+ individual small shapes? There seems to be no functionality to combine all of the shapes into a single shape.
Another solution I thought about is simultaneously generating all of the QR codes, instead of iteratively, then perhaps it won't have the issue of the later-coming shapes being slow to render due to having to hold all of the previously rendered codes in its memory. I haven't found a way to write the code such that all QR code image shapes are generated in parallel, rather than in sequence.
Another solution I toyed with is to paste the shapes as PNG or some other image that could potentially be easier to deal with, but I get a lot of loss of quality, which seems strange because the QR code should be just a matrix of black and white cells, right? Why do they lose so much quality?
I would suggest an approach based on built in MS Word 2013+ feature (https://support.microsoft.com/en-us/office/field-codes-displaybarcode-6d81eade-762d-4b44-ae81-f9d3d9e07be3). Below is an example of generating 200 QR codes in 10.6 seconds:
Option Explicit
Sub MakeQRcodes()
Const QR_COUNT = 200
Dim fld As Field, tbl As Table, rng As Range
Dim Code As String, i As Integer, t As Single
t = Timer
ThisDocument.Range.Delete
Set tbl = ThisDocument.Tables.Add(Range:=Selection.Range, NumRows:=QR_COUNT, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed)
For i = 1 To QR_COUNT
Code = "Insect #" & i ' data can be obtained from Excel spreadsheet
tbl.Cell(i, 1).Range.Text = "QR code for [" & Code & "]:"
Set rng = tbl.Cell(i, 2).Range
rng.Collapse Direction:=wdCollapseStart
Set fld = ThisDocument.Fields.Add(Range:=rng, Type:=wdFieldEmpty, _
Text:="DisplayBarcode """ & Code & """ QR \q 3")
Next i
ThisDocument.ActiveWindow.View.ShowFieldCodes = False
With tbl.Range
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
Debug.Print "Done " & QR_COUNT & " items in " & Timer - t & " seconds"
End Sub
' Done 200 items in 10,62109 seconds
Result:
Edit2 (VBA Excel code)
Please note that in my experience the DisplayBarcode field works well only with the Latin alphabet. If you have other symbols, check the code on real lines.
Option Explicit
Sub makeQRs()
Dim arr
arr = ThisWorkbook.Sheets("Sheet1").ListObjects("Table1").DataBodyRange.Columns(3)
Call MakeQRcodes(arr)
End Sub
Sub MakeQRcodes(arr) ' arr(n,1)
'you need to add a reference to the "Microsoft Word Object Library" in the Tools-References VBE menu
Dim wd As New Word.Application, doc As Word.Document, fld As Word.Field, tbl As Word.Table, rng As Word.Range
Dim Code As String, i As Integer, QR_count As Integer, t As Single
QR_count = UBound(arr, 1)
t = Timer
wd.Visible = False ' hide the Word app
Set doc = wd.Documents.Add ' create a new Word document
Set tbl = doc.Tables.Add(Range:=doc.Range, NumRows:=QR_count, _
NumColumns:=2, DefaultTableBehavior:=1) 'wdWord9TableBehavior = 1
For i = 1 To QR_count
Code = arr(i, 1)
tbl.Cell(i, 1).Range.Text = "QR code for [" & Code & "]:"
Set rng = tbl.Cell(i, 2).Range
rng.Collapse Direction:=wdCollapseStart
Set fld = doc.Fields.Add(Range:=rng, Type:=-1, _
Text:="DisplayBarcode """ & Code & """ QR \q 3")
Next i
doc.ActiveWindow.View.ShowFieldCodes = False
With tbl.Range ' center text and QR-code in the table cells
.ParagraphFormat.Alignment = 1 'wdAlignParagraphCenter
.Cells.VerticalAlignment = 1 'wdCellAlignVerticalCenter
End With
Application.DisplayAlerts = 0 'wdAlertsNone
With doc
' save the Word doc as .pdf in the same folder as this Excel workbook
.SaveAs2 ThisWorkbook.Path & "\QR.pdf", 17 'wdFormatPDF
.Close False ' close Word document without saving
wd.Quit ' close Word app
End With
Application.DisplayAlerts = -1 'wdAlertsAll
MsgBox "Done " & QR_count & " QR-codes in " & Round(Timer - t, 1) & " seconds," & vbLf _
& "saved in " & ThisWorkbook.Path & "\QR.pdf"
End Sub
Data & result MsgBox
QR.pdf

Copy/Paste Excel cells to Word in loop not working/saving properly

Admittedly new to VBA. I have an excel file that consists of all our part numbers broken down by "-" marks that I wrote code to break down into more descriptive phrases for making labels. I am trying to write code here to loop through different types of part numbers, grab particular cells in that part #'s row and copy/pasting them into a word document and saving the word doc as the part #'s name. As is, it loops but grabs all the info from the different ranges instead of just the info from the same row as part.
The code works (besides saving) if I change the ranges to 1 single cell, but once I have multiple cells in the ranges, it begins copying everything in the range instead of just in the row of the part that it should be looping.
Sub exceltoword2()
Dim part As Range
Dim funct As Range
Dim finish As Range
Dim lever As Range
Dim backset As Range
Dim trim As Range
Set part = Range("A2:A5")
Set funct = Range("Q2:Q5")
Set finish = Range("R2:R5")
Set lever = Range("S2:S5")
Set backset = Range("T2:T5")
Set trim = Range("U2:U5")
Dim wdapp As Word.Application
Set wdapp = New Word.Application
Dim SaveName As String
Dim path As String
path = "C:\Users\bpickett\Desktop\Parts\"
For Each part In part 'Long list of part #'s that will be looped through with particular variables commented out as needed as I adjust range on part variable
With wdapp
.Visible = True
.Documents.Add
.Activate
part.Copy '********************************Part copied
.Selection.PasteSpecial
With .Selection '**********************Function copied
.Font.Name = "Calibri"
.Font.Size = 22
.TypeText "FUNCTION " '7 spaces
End With
funct.Copy
.Selection.PasteSpecial
With .Selection '**************************Finish
.Font.Name = "Calibri"
.Font.Size = 22
.TypeText "FINISH " '14 spaces
End With
finish.Copy
.Selection.PasteSpecial
With .Selection '***************************Backset
.Font.Name = "Calibri"
.Font.Size = 22
.TypeText "BACKSET " '10 spaces
End With
backset.Copy
.Selection.PasteSpecial
ActiveDocument.SaveAs2 path & part & ".docx"
End With
Next
End Sub
The code when ran has the 1st part # correct then, just copies the entire range of Backset/Function/Finish under each instead of just the single cell in the row of the part #.
Took advice from comments above and did a days more worth of research and made some changes that solved all problems.
For i = 1 to 1275
Set part = Range("A" & i)
Set funct = Range("Q" & i)
Set finish = Range("R" & i)
Set lever = Range("S" & i)
Set backset = Range("T" & i)
Set trim = Range("U" & i)
Qualifying the ranges(or at least to me it did) and adding the i array instead of for each part in part was huge for code to loop and grab only necessary information. But when running, it was crashing with error 4605 a lot. But a 7 year old question that was answered on here surrounded the copy/paste commands with labels and error handler
Pg1CopyAttempt:
DoEvents
part.Copy
On Error GoTo Pg1PasteFail
.selection.pastespecial
On Error goto 0 'disable the error handler
Pg1PasteFail:
If Err.Number = 4605 Then ' clipboard is empty or not valid.
DoEvents
Resume Pg1CopyAttempt
End If
Which worked FLAWLESSLY to go through strings of 100's or 1000's of loops(Files created). Just had to modify Pg1 to 2 to 3 and ect through code.

Can't set footnote in Word doc using Excel VBA

I have numerous WORD documents that have several Content Controls in them. I am using an Excel file to update the WORD docs. When I make an update, I need to insert a footnote describing the change. I can update the contents of the Content Control just fine, but I am having problems inserting the footnote. Here's my code:
Set cc = oRange.ContentControls(intCounter)
strOriginalDate = cc.Range.Text
If wrdDoc.ProtectionType <> wdNoProtection Then
wrdDoc.Unprotect strSheetPassword
End If
If wrdDoc.FormsDesign = False Then
wrdDoc.ToggleFormsDesign
End If
cc.Range.Text = strCOD
'
' Insert the footnote
'
oRange = wrdDoc.Range(cc.Range.End, cc.Range.End)
oRange.Select
Selection.MoveRight Units:=wdCharacter, Count:=1
Selection.TypeText Text:=" "
With Selection
With .FootnoteOptions
.Location = wdBottomOfPage
.NumberingRule = wdRestartContinuous
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
.LayoutColumns = 0
End With
.Footnotes.Add Range:=cc.Range, Text:="Case Opening Date changed from " & _
strOriginalDate & " to " & strCOD & " on " & Date, Reference:=""
End If
End With
wrdDoc.ToggleFormsDesign
wrdDoc.Protect Type:=wdAllowOnlyFormFields, Password:=strSheetPassword
wrdDoc.Save
When I get down to the line Selection.MoveRight Units:=wdCharacter, Count:=1, I get an error that says Object doesn't support this property or method. In essence, I'm trying to move to the end of the control, then on the next step, I'm trying to move beyond/outside the control.
When I comment out that line and the line that follows it, I end up trying to insert the footnote into the content control. That fails on the With .FootnoteOptions line, possibly because the content control I'm using is a date picker.
You are correct that you can't add a footnote inside of a Content Control. The solution is exactly what you are trying to do - put it in the document after. The problem is that you are trying to add it using the Selection object.
Since you already have a Range within the context of the Document (oRange), just work with it directly:
'
' Insert the footnote
'
'Move the oRange to an "insertion point" after the control.
oRange.Start = cc.Range.End + 1
'Collapse it.
oRange.End = oRange.Start
'Add your space.
oRange.Text = " "
With oRange.FootnoteOptions
.Location = wdBottomOfPage
.NumberingRule = wdRestartContinuous
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
.LayoutColumns = 0
End With
oRange.Footnotes.Add Range:=oRange, Text:="Case Opening Date changed from " & _
strOriginalDate & " to " & strCOD & " on " & Date
There's really no reason to be mucking around with the Selection - it's just a glorified Range with the added benefit of doing all the annoying things that Word does "for your benefit" (like grabbing the trailing space) while you're highlighting with the mouse.
I'll also note that you can omit the Reference:="" - it gets set to an empty string by default. You also have a floating End If inside your With block.

Generate Word Documents (in Excel VBA) from a series of Document Templates

Hey all. I'll try to make this brief and simple. :)
I have
40 or so boilerplate word documents with a series of fields (Name, address, etc) that need to be filled in. This is historically done manually, but it's repetitive and cumbersome.
A workbook where a user has filled a huge set of information about an individual.
I need
A way to programatically (from Excel VBA) open up these boilerplate documents, edit in the value of fields from various named ranges in the workbook, and save the filled in templates to a local folder.
If I were using VBA to programatically edit particular values in a set of spreadsheets, I would edit all those spreadsheets to contain a set of named ranges which could be used during the auto-fill process, but I'm not aware of any 'named field' feature in a Word document.
How could I edit the documents, and create a VBA routine, so that I can open each document, look for a set of fields which might need to be filled in, and substitute a value?
For instance, something that works like:
for each document in set_of_templates
if document.FieldExists("Name") then document.Field("Name").value = strName
if document.FieldExists("Address") then document.Field("Name").value = strAddress
...
document.saveAs( thisWorkbook.Path & "\GeneratedDocs\ " & document.Name )
next document
Things I've considered:
Mail merge - but this is insufficient because it requires opening each document manually and structuring the workbook as a data source, I kind of want the opposite. The templates are the data source and the workbook is iterating through them. Also, mail merge is for creating many identical documents using a table of different data. I have many documents all using the same data.
Using placeholder text such as "#NAME#" and opening each document for a search and replace. This is the solution I would resort to if nothing more elegant is proposed.
It's been a long time since I asked this question, and my solution has undergone more and more refinement. I've had to deal with all sorts of special cases, such as values that come directly from the workbook, sections that need to be specially generated based on lists, and the need to do replacements in headers and footers.
As it turns out, it did not suffice to use bookmarks, as it was possible for users to later edit documents to change, add, and remove placeholder values from the documents. The solution was in fact to use keywords such as this:
This is just a page from a sample document which uses some of the possible values that can get automatically inserted into a document. Over 50 documents exist with completely different structures and layouts, and using different parameters. The only common knowledge shared by the word documents and the excel spreadsheet is a knowledge of what these placeholder values are meant to represent. In excel, this is stored in a list of document generation keywords, which contain the keyword, followed by a reference to the range that actually contains this value:
These were the key two ingredients required. Now with some clever code, all I had to do was iterate over each document to be generated, and then iterate over the range of all known keywords, and do a search and replace for each keyword in each document.
First, I have the wrapper method, which takes care of maintaining an instance of microsoft word iterating over all documents selected for generation, numbering the documents, and doing the user interface stuff (like handling errors, displaying the folder to the user, etc.)
' Purpose: Iterates over and generates all documents in the list of forms to generate
' Improves speed by creating a persistant Word application used for all generated documents
Public Sub GeneratePolicy()
Dim oWrd As New Word.Application
Dim srcPath As String
Dim cel As Range
If ERROR_HANDLING Then On Error GoTo errmsg
If Forms.Cells(2, FormsToGenerateCol) = vbNullString Then _
Err.Raise 1, , "There are no forms selected for document generation."
'Get the path of the document repository where the forms will be found.
srcPath = FindConstant("Document Repository")
'Each form generated will be numbered sequentially by calling a static counter function. This resets it.
GetNextEndorsementNumber reset:=True
'Iterate over each form, calling a function to replace the keywords and save a copy to the output folder
For Each cel In Forms.Range(Forms.Cells(2, FormsToGenerateCol), Forms.Cells(1, FormsToGenerateCol).End(xlDown))
RunReplacements cel.value, CreateDocGenPath(cel.Offset(0, 1).value), oWrd
Next cel
oWrd.Quit
On Error Resume Next
'Display the folder containing the generated documents
Call Shell("explorer.exe " & CreateDocGenPath, vbNormalFocus)
oWrd.Quit False
Application.StatusBar = False
If MsgBox("Policy generation complete. The reserving information will now be recorded.", vbOKCancel, _
"Policy Generated. OK to store reserving info?") = vbOK Then Push_Reserving_Requirements
Exit Sub
errmsg:
MsgBox Err.Description, , "Error generating Policy Documents"
End Sub
That routine calls RunReplacements which takes care of opening the document, prepping the environment for a fast replacement, updating links once done, handling errors, etc:
' Purpose: Opens up a document and replaces all instances of special keywords with their respective values.
' Creates an instance of Word if an existing one is not passed as a parameter.
' Saves a document to the target path once the template has been filled in.
'
' Replacements are done using two helper functions, one for doing simple keyword replacements,
' and one for the more complex replacements like conditional statements and schedules.
Private Sub RunReplacements(ByVal DocumentPath As String, ByVal SaveAsPath As String, _
Optional ByRef oWrd As Word.Application = Nothing)
Dim oDoc As Word.Document
Dim oWrdGiven As Boolean
If oWrd Is Nothing Then Set oWrd = New Word.Application Else oWrdGiven = True
If ERROR_HANDLING Then On Error GoTo docGenError
oWrd.Visible = False
oWrd.DisplayAlerts = wdAlertsNone
Application.StatusBar = "Opening " & Mid(DocumentPath, InStrRev(DocumentPath, "\") + 1)
Set oDoc = oWrd.Documents.Open(Filename:=DocumentPath, Visible:=False)
RunAdvancedReplacements oDoc
RunSimpleReplacements oDoc
UpdateLinks oDoc 'Routine which will update calculated statements in Word (like current date)
Application.StatusBar = "Saving " & Mid(DocumentPath, InStrRev(DocumentPath, "\") + 1)
oDoc.SaveAs SaveAsPath
GoTo Finally
docGenError:
MsgBox "Un unknown error occurred while generating document: " & DocumentPath & vbNewLine _
& vbNewLine & Err.Description, vbCritical, "Document Generation"
Finally:
If Not oDoc Is Nothing Then oDoc.Close False: Set oDoc = Nothing
If Not oWrdGiven Then oWrd.Quit False
End Sub
That routine then invokes RunSimpleReplacements. and RunAdvancedReplacements. In the former, we iterate over the set of Document Generation Keywords and call WordDocReplace if the document contains our keyword. Note that it's much faster to try and Find a bunch of words to figure out that they don't exist, then to call replace indiscriminately, so we always check if a keyword exists before attempting to replace it.
' Purpose: While short, this short module does most of the work with the help of the generation keywords
' range on the lists sheet. It loops through every simple keyword that might appear in a document
' and calls a function to have it replaced with the corresponding data from pricing.
Private Sub RunSimpleReplacements(ByRef oDoc As Word.Document)
Dim DocGenKeys As Range, valueSrc As Range
Dim value As String
Dim i As Integer
Set DocGenKeys = Lists.Range("DocumentGenerationKeywords")
For i = 1 To DocGenKeys.Rows.Count
If WordDocContains(oDoc, "#" & DocGenKeys.Cells(i, 1).Text & "#") Then
'Find the text that we will be replacing the placeholder keyword with
Set valueSrc = Range(Mid(DocGenKeys.Cells(i, 2).Formula, 2))
If valueSrc.MergeCells Then value = valueSrc.MergeArea.Cells(1, 1).Text Else value = valueSrc.Text
'Perform the replacement
WordDocReplace oDoc, "#" & DocGenKeys.Cells(i, 1).Text & "#", value
End If
Next i
End Sub
This is the function used to detect whether a keyword exists in the document:
' Purpose: Function called for each replacement to first determine as quickly as possible whether
' the document contains the keyword, and thus whether replacement actions must be taken.
Public Function WordDocContains(ByRef oDoc As Word.Document, ByVal searchFor As String) As Boolean
Application.StatusBar = "Checking for keyword: " & searchFor
WordDocContains = False
Dim storyRange As Word.Range
For Each storyRange In oDoc.StoryRanges
With storyRange.Find
.Text = searchFor
WordDocContains = WordDocContains Or .Execute
End With
If WordDocContains Then Exit For
Next
End Function
And this is where the rubber meets the road - the code that executes the replacement. This routine got more complicated as I encountered difficulties. Here are the lessons you will only learn from experience:
You can set the replacement text directly, or you can use the clipboard. I found out the hard way that if you are doing a VBA replace in word using a string longer than 255 characters, the text will get truncated if you try to place it in the Find.Replacement.Text, but you can use "^c" as your replacement text, and it will get it directly from the clipboard. This was the workaround I got to use.
Simply calling replace will miss keywords in some text areas like headers and footers. Because of this, you actually need to iterate over the document.StoryRanges and run the search and replace on each one to ensure that you catch all instances of the word you want to replace.
If you're setting the Replacement.Text directly, you need to convert Excel line breaks (vbNewLine and Chr(10)) with a simple vbCr for them to appear properly in word. Otherwise, anywhere your replacement text has line breaks coming from an excel cell will end up inserting strange symbols into word. If you use the clipboard method however, you do not need to do this, as the line breaks get converted automatically when put in the clipboard.
That explains everything. Comments should be pretty clear too. Here's the golden routine that executes the magic:
' Purpose: This function actually performs replacements using the Microsoft Word API
Public Sub WordDocReplace(ByRef oDoc As Word.Document, ByVal replaceMe As String, ByVal replaceWith As String)
Dim clipBoard As New MSForms.DataObject
Dim storyRange As Word.Range
Dim tooLong As Boolean
Application.StatusBar = "Replacing instances of keyword: " & replaceMe
'We want to use regular search and replace if we can. It's faster and preserves the formatting that
'the keyword being replaced held (like bold). If the string is longer than 255 chars though, the
'standard replace method doesn't work, and so we must use the clipboard method (^c special character),
'which does not preserve formatting. This is alright for schedules though, which are always plain text.
If Len(replaceWith) > 255 Then tooLong = True
If tooLong Then
clipBoard.SetText IIf(replaceWith = vbNullString, "", replaceWith)
clipBoard.PutInClipboard
Else
'Convert excel in-cell line breaks to word line breaks. (Not necessary if using clipboard)
replaceWith = Replace(replaceWith, vbNewLine, vbCr)
replaceWith = Replace(replaceWith, Chr(10), vbCr)
End If
'Replacement must be done on multiple 'StoryRanges'. Unfortunately, simply calling replace will miss
'keywords in some text areas like headers and footers.
For Each storyRange In oDoc.StoryRanges
Do
With storyRange.Find
.MatchWildcards = True
.Text = replaceMe
.Replacement.Text = IIf(tooLong, "^c", replaceWith)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
On Error Resume Next
Set storyRange = storyRange.NextStoryRange
On Error GoTo 0
Loop While Not storyRange Is Nothing
Next
If tooLong Then clipBoard.SetText ""
If tooLong Then clipBoard.PutInClipboard
End Sub
When the dust settles, we're left with a beautiful version of the initial document with production values in place of those hash marked keywords. I'd love to show an example, but of course every filled in document contain all-proprietary information.
The only think left to mention I guess would be that RunAdvancedReplacements section. It does something extremely similar - it ends up calling the same WordDocReplace function, but what's special about the keywords used here is that they don't link to a single cell in the original workbook, they get generated in the code-behind from lists in the workbook. So for instance, one of the advanced replacements would look like this:
'Generate the schedule of vessels
If WordDocContains(oDoc, "#VESSELSCHEDULE#") Then _
WordDocReplace oDoc, "#VESSELSCHEDULE#", GenerateVesselSchedule()
And then there will be a corresponding routine which puts together a string containing all the vessel information as configured by the user:
' Purpose: Generates the list of vessels from the "Vessels" sheet based on the user's configuration
' in the booking tab. The user has the option to generate one or both of Owned Vessels
' and Chartered Vessels, as well as what fields to display. Uses a helper function.
Public Function GenerateVesselSchedule() As String
Dim value As String
Application.StatusBar = "Generating Schedule of Vessels."
If Booking.Range("ListVessels").value = "Yes" Then
Dim VesselCount As Long
If Booking.Range("ListVessels").Offset(1).value = "Yes" Then _
value = value & GenerateVesselScheduleHelper("Vessels", VesselCount)
If Booking.Range("ListVessels").Offset(1).value = "Yes" And _
Booking.Range("ListVessels").Offset(2).value = "Yes" Then _
value = value & "(Chartered Vessels)" & vbNewLine
If Booking.Range("ListVessels").Offset(2).value = "Yes" Then _
value = value & GenerateVesselScheduleHelper("CharteredVessels", VesselCount)
If Len(value) > 2 Then value = Left(value, Len(value) - 2) 'Remove the trailing line break
Else
GenerateVesselSchedule = Booking.Range("VesselSchedAlternateText").Text
End If
GenerateVesselSchedule = value
End Function
' Purpose: Helper function for the Vessel Schedule generation routine. Generates either the Owned or
' Chartered vessels based on the schedule parameter passed. The list is numbered and contains
' the information selected by the user on the Booking sheet.
' SENSITIVE: Note that this routine is sensitive to the layout of the Vessel Schedule tab and the
' parameters on the Configure Quotes tab. If either changes, it should be revisited.
Public Function GenerateVesselScheduleHelper(ByVal schedule As String, ByRef VesselCount As Long) As String
Dim value As String, nextline As String
Dim numInfo As Long, iRow As Long, iCol As Long
Dim Inclusions() As Boolean, Columns() As Long
'Gather info about vessel info to display in the schedule
With Booking.Range("VesselInfoToInclude")
numInfo = Booking.Range(.Cells(1, 1), .End(xlToRight)).Columns.Count - 1
ReDim Inclusions(1 To numInfo)
ReDim Columns(1 To numInfo)
On Error Resume Next 'Some columns won't be identified
For iCol = 1 To numInfo
Inclusions(iCol) = .Offset(0, iCol) = "Yes"
Columns(iCol) = sumSchedVessels.Range(schedule).Cells(1).EntireRow.Find(.Offset(-1, iCol)).Column
Next iCol
On Error GoTo 0
End With
'Build the schedule
With sumSchedVessels.Range(schedule)
For iRow = .row + 1 To .row + .Rows.Count - 1
If Len(sumSchedVessels.Cells(iRow, Columns(1)).value) > 0 Then
VesselCount = VesselCount + 1
value = value & VesselCount & "." & vbTab
nextline = vbNullString
'Add each property that was included to the description string
If Inclusions(1) Then nextline = nextline & sumSchedVessels.Cells(iRow, Columns(1)) & vbTab
If Inclusions(2) Then nextline = nextline & "Built: " & sumSchedVessels.Cells(iRow, Columns(2)) & vbTab
If Inclusions(3) Then nextline = nextline & "Length: " & _
Format(sumSchedVessels.Cells(iRow, Columns(3)), "#'") & vbTab
If Inclusions(4) Then nextline = nextline & "" & sumSchedVessels.Cells(iRow, Columns(4)) & vbTab
If Inclusions(5) Then nextline = nextline & "Hull Value: " & _
Format(sumSchedVessels.Cells(iRow, Columns(5)), "$#,##0") & vbTab
If Inclusions(6) Then nextline = nextline & "IV: " & _
Format(sumSchedVessels.Cells(iRow, Columns(6)), "$#,##0") & vbTab
If Inclusions(7) Then nextline = nextline & "TIV: " & _
Format(sumSchedVessels.Cells(iRow, Columns(7)), "$#,##0") & vbTab
If Inclusions(8) And schedule = "CharteredVessels" Then _
nextline = nextline & "Deductible: " & Format(bmCharterers.Range(schedule).Cells( _
iRow - .row, 9), "$#,##0") & vbTab
nextline = Left(nextline, Len(nextline) - 1) 'Remove the trailing tab
'If more than 4 properties were included insert a new line after the 4th one
Dim tabloc As Long: tabloc = 0
Dim counter As Long: counter = 0
Do
tabloc = tabloc + 1
tabloc = InStr(tabloc, nextline, vbTab)
If tabloc > 0 Then counter = counter + 1
Loop While tabloc > 0 And counter < 4
If counter = 4 Then nextline = Left(nextline, tabloc - 1) & vbNewLine & Mid(nextline, tabloc)
value = value & nextline & vbNewLine
End If
Next iRow
End With
GenerateVesselScheduleHelper = value
End Function
the resulting string can be used just like the contents of any excel cell, and passed to the replacement function, which will appropriately use the clipboard method if it exceeds 255 characters.
So this template:
Plus this spreadsheet data:
Becomes this document:
I sincerely hope that this helps someone out some day. It was definitely a huge undertaking and a complex wheel to have to re-invent. The application is huge, with over 50,000 lines of VBA code, so if I've referenced a crucial method in my code somewhere that someone needs, please leave a comment and I'll add it in here.
http://www.computorcompanion.com/LPMArticle.asp?ID=224 Describes the use of Word bookmarks
A section of text in a document can be bookmarked, and given a variable name. Using VBA, this variable can be accessed and the content in the document can be replaced with alternate content. This is a solution to having placeholders such as Name and Address in the document.
Furthermore, using bookmarks, documents can be modified to reference bookmarked text. If a name appears several times throughout a document, the first instance can be bookmarked, and additional instances can reference the bookmark. Now when the first instance is programatically changed, all other instances of the variable throughout the document are also automatically changed.
Now all that's needed is to update all the documents by bookmarking the placeholder text and using a consistent naming convention throughout the documents, then iterate through each documents replacing the bookmark if it exists:
document.Bookmarks("myBookmark").Range.Text = "Inserted Text"
I can probably solve the problem of variables that don't appear in a given document using the on error resume next clause before attempting each replacement.
Thanks to Doug Glancy for mentioning the existance of bookmarks in his comment. I had no knowledge of their existence beforehand. I will keep this topic posted on whether this solution suffices.
You might consider an XML based approach.
Word has a feature called Custom XML data-binding, or data-bound content controls. A content control is essentially a point in the document which can contain content. A "data-bound" content control gets its content from an XML document you include in the docx zip file. An XPath expression is used to say which bit of XML. So all you need to do is include your XML file, and Word will do the rest.
Excel has ways to get data out of it as XML, so the whole solution should work nicely.
There is plenty of information on content control data-binding on MSDN (some of which has been referenced in earlier SO questions) so I won't bother including them here.
But you do need a way of setting up the bindings. You can either use the Content Control Toolkit, or if you want to do it from within Word, my OpenDoPE add-in.
Having done a similar task I found that inserting values into tables was much quicker than searching for named tags - the data can then be inserted like this:
With oDoc.Tables(5)
For i = 0 To Data.InvoiceDictionary.Count - 1
If i > 0 Then
oDoc.Tables(5).rows.Add
End If
Set invoice = Data.InvoiceDictionary.Items(i)
.Cell(i + 2, 1).Range.Text = invoice.InvoiceCCNumber
.Cell(i + 2, 2).Range.Text = invoice.InvoiceDate
.Cell(i + 2, 3).Range.Text = invoice.TransactionType
.Cell(i + 2, 4).Range.Text = invoice.Description
.Cell(i + 2, 5).Range.Text = invoice.SumOfValue
Next i
.Cell(i + 1, 4).Range.Text = "Total:"
End With
in this case row 1 of the table was the headers; row 2 was empty and there were no further rows - thus the rows.add applies once more than one row was attached. The tables can be very detailed documents and by hiding the borders and cell borders can be made to look like ordinary text. Tables are numbered sequentially following the document flow. (i.e. Doc.Tables(1) is the first table...

Resources