Is there a way to determine whether or not a Word document (specifically 2007, if that matters) contains a restricted font using VBA?
I don't necessarily need a way to remove the font, just to determine whether or not the document contains an restricted font. Also, if there's only a way to check for an embedded font, that's acceptable, because in my case, it will almost always be a restricted font.
As you're using Word 2007 you can try to inspect the OOXML of the document to check whether a particular font is embedded or not. As far as I can determine, if it is embedded then in the XML, the font will have one or more of the following child nodes:
< w:embedRegular>
< w:embedBold>
< w:embedItalic>
< w:embedBoldItalic>
(had to put in spaces otherwise it would not display correctly)
More information here: http://msdn.microsoft.com/en-us/library/documentformat.openxml.wordprocessing.font.aspx
Based on this, you can then put something together to extract this information - I threw together an example below that looks at the active document.
I have to admit this is not that pretty and it could certainly do with some optimisation, but it does the job. Don't forget to add a reference to MSXML to your VBA project.
' returns a delimited list of fonts that are embedded
Function GetEmbeddedFontList(Optional ByVal sDelimiter As String = ";") As String
Dim objDOMDocument As MSXML2.DOMDocument30
Dim objXMLNodeList As MSXML2.IXMLDOMNodeList
Dim objXMLNodeListEmbed As MSXML2.IXMLDOMNodeList
Dim lNodeNum As Long
Dim lNodeNum2 As Long
Dim sFontName As String
Dim sReturnValue As String
On Error GoTo ErrorHandler
sReturnValue = ""
Set objDOMDocument = New MSXML2.DOMDocument30
objDOMDocument.LoadXML ActiveDocument.WordOpenXML
' grab the list of fonts used in the document
Set objXMLNodeList = objDOMDocument.SelectNodes("//w:fonts/w:font")
For lNodeNum = 0 To objXMLNodeList.Length - 1
' obtain the font's name
sFontName = objXMLNodeList.Item(lNodeNum).Attributes(0).Text
'check its child nodes to see if any contain the word "embed", if so, then the font is embedded
For lNodeNum2 = 0 To objXMLNodeList.Item(lNodeNum).ChildNodes.Length - 1
If objXMLNodeList.Item(lNodeNum).ChildNodes(lNodeNum2).nodeName Like "*embed*" Then
sReturnValue = sReturnValue & sFontName & sDelimiter ' add it to the list
Exit For
End If
Next lNodeNum2
Next lNodeNum
ErrorExit:
GetEmbeddedFontList = sReturnValue
Exit Function
ErrorHandler:
sReturnValue = ""
Resume ErrorExit:
End Function
Related
I am trying to read one pdf and a VBA userform and then fill out another pdf.
I wrote code to read all text in a pdf and then find certain sub strings based on tokens that I can find in the string. It is intended to populate the fields in the destination pdf based on the substrings and check the appropriate text boxes based on the user form. I can get the code to fill the substrings and then save the document, but it won't check the boxes.
Before the code used a AVDoc, but I switched to a JSO because I don't want the pdf to pop up, and the jso avoids that problem.
I tried pdfBool.value = cBool(vbaBool), pdfBool.value = 1, pdfBool.value = "1", jso.setValue("checked"), jso.setValue("yes"), etc.
This code will run without crashing. I reduced the number of variables to one string and one bool for the sake of the example.
Sub main()
‘findString grabs all text from a pdf file. This code works.
Dim mystr As String
If findString(mystr) = False Then
Application.StatusBar = "Cannot find Source PDF"
Exit Sub
End If
Dim mypath As String
mypath = ActiveWorkbook.Path & "\destination.pdf"
Dim aApp As acrobat.AcroApp
Dim pdfDoc As acrobat.CAcroPDDoc
Dim jso As Object
Set aApp = CreateObject("AcroExch.App")
Set pdfDoc = CreateObject("AcroExch.PDDoc")
If pdfDoc.Open(mypath) = True Then
Set jso = pdfDoc.GetJSObject
Dim vbaText As String
Dim vbaBool As String
vbaText = returnString("Token1")
vbaBool = userForm.checkBox1.value
Dim pdfText As Object
Dim pdfBool As Object
Set pdfText = jso.getField("TextField1")
Set pdfBool = jso.getField("CheckBox1")
pdfText.Value = vbaText
pdfBool.Value = vbaBool
'save pdffile
Dim fileSavePath As String
fileSavePath = ActiveWorkbook.Path & "\My Save File.pdf"
pdfDoc.Save PDSaveFull, fileSavePath
'clean up memory
Set pdfDoc = Nothing
Set pdfText = Nothing
Set pdfBool = Nothing
Set jso = Nothing
End If
aApp.Exit
Set aApp = Nothing
Unload userForm1
End Sub
Ok, so after some searching, I have found a solution. Basically, forms created using Living Cycle don't work well with checkboxes. I asked somebody in my organization and they confirmed that Living Cycle was used on forms for a while until we got rid of it. Honestly, I don't know what Living Cycle is, but the solution seemed to work and so I think whatever the issue was related to something called "Living Cycle".
The solution? Redo the pdf form: I exported the pdf to an Encapsulated PostScript file. This stripped away all the fields. After that, I used the prepare form tool which automatically found all the relevant fields. Fortunately, with my pdf, it found all of the fields perfectly, though there was one or two extra ones that I had to delete. The field names and the code need to match so adjustments need to either be made to the PDF or to the code, but once I made that adjustment, everything was perfect.
Try jso.getfield(pdfFieldName).Value = "Yes" or "No". The value is case sensitive so you have to use Yes or No.
I'm getting this error, "Microsoft Excel is waiting for another application to complete an OLE action" when trying to automate a PDF string search and record findings in excel. For certain PDFs this error is not popping. I assume this is due to the less optimized PDFs taking a longer time to search string while indexing page by page.
To be more precise, I have a workbook containing two sheets. One contains a list of PDF file names and the other has a list of words that I want to search. From the file list the macro would open each PDF file and take each word from the list of words and perform a string search. If found it would record each finding in a new sheet in the same workbook with the file name and the found string.
Below is the code I'm struggling with. Any help is welcome.
Public Sub SearchWords()
'variables
Dim ps As Range
Dim fs As Range
Dim PList As Range
Dim FList As Range
Dim PLRow As Long
Dim FLRow As Long
Dim Tracker As Worksheet
Dim gapp As Object
Dim gAvDoc As Object
Dim gPDFPath As String
Dim sText As String 'String to search for
FLRow = ActiveWorkbook.Sheets("List Files").Range("B1").End(xlDown).Row
PLRow = ActiveWorkbook.Sheets("Prohibited Words").Range("A1").End(xlDown).Row
Set PList = ActiveWorkbook.Sheets("Prohibited Words").Range("A2:A" & PLRow)
Set FList = ActiveWorkbook.Sheets("List Files").Range("B2:B" & FLRow)
Set Tracker = ActiveWorkbook.Sheets("Tracker")
'For each PDF file list in Excel Range
For Each fs In FList
'Initialize Acrobat by creating App object
Set gapp = CreateObject("AcroExch.App")
'Set AVDoc object
Set gAvDoc = CreateObject("AcroExch.AVDoc")
'Set PDF file path to open in PDF
gPDFPath = fs.Cells.Value
' open the PDF
If gAvDoc.Open(gPDFPath, "") = True Then
'Bring the PDF to front
gAvDoc.BringToFront
'For each word list in the range
For Each ps In PList
'Assign String to search
sText = ps.Cells.Value
'This is where the error is appearing
If gAvDoc.FindText(sText, False, True, False) = True Then
'Record findings
Tracker.Range("A1").End(xlDown).Offset(1, 0) = fs.Cells.Offset(0, -1).Value
Tracker.Range("B1").End(xlDown).Offset(1, 0) = ps.Cells.Value
End If
Next
End If
'Message to display once the search is over for a particular PDF
MsgBox (fs.Cells.Offset(0, -1).Value & " assignment complete")
Next
gAvDoc.Close True
gapp.Exit
set gAVDoc = Nothing
set gapp = Nothing
End Sub
I have now found the answer to this problem.
I'm using Acrobat Pro and whenever I open a PDF file, it opens with limited features due to Protected View settings. If I disable this function or if I click Enable All Features and save changes to the PDF files, VBA macro runs smooth.
It's funny, I'm posting an answer to my own problem.
I have this .dwg file that has hundreds of block references.
I am trying to create hyperlink to a pdf file from all of the block references. The pdf are on my D drive.
For example, names of the block refernece are: '2:test', '26:test', '234:test'. Essentially hyperlink for
each point would be: '2:test' would hyperlink to D:\Reports\File-002.pdf;
'26:test' would hyperlink to D:\Reports\File-026.pdf; '234:test' would hyperlink to D:\Reports\File-234.pdf.
From block
references i get the number before the ':', and its matching pdf would be 'File-' followed by the number before ':' in 3 digits.
There are lot of these to do by hands, and i think i can program for this.
I have enough basic programming knowledge to manipulate the string to get my number and convert it in 3 digits. The question i have
and/or need help is with how to cycle through each block reference(for loop) on the file and be able to write to its hyperlink property? Is this even possible?
Before coming here i kind of looked at these links but they did not prove helpful:
Link1; Link2; Link3
Thanks for the hints
UPDATE
Private Sub CommandButton1_Click()
Dim ReadData As String
Open "C:\Desktop\Files\DesignFile.DWG" For Input As #1
Do Until EOF(1)
Line Input #1, ReadData
MsgBox ReadData 'Adding Line to read the whole line, not only first 128 positions
Loop
Close #1
End Sub
You can try this:
Dim stringInput
stringInput = "2:test', '26:test', '234:test"
stringSplit = Split(stringInput, ",")
For i = 0 To UBound(stringSplit)
Debug.Print (stringSplit(i))
Next i
Outputs:
2:test'
'26:test'
'234:test
you can try this
Option Explicit
Sub test()
Dim acBlockRef As AcadBlockReference
Dim baseStrng As String
baseStrng = "D:\Reports\File-"
For Each acBlockRef In BlockRefsSSet("BlockRefs")
acBlockRef.Hyperlinks.Add("PDF").URL = baseStrng & Format(Left(acBlockRef.Name, InStr(acBlockRef.Name, "-") - 1), "000") & ".pdf"
Next acBlockRef
ThisDrawing.SelectionSets("BlockRefs").Delete
End Sub
'-----------------------------------------------------------------
'helper functions
'------------------
Function BlockRefsSSet(ssetName As String, Optional acDoc As Variant) As AcadSelectionSet
'returns a selection set of all block references in the passed drawing
Dim acSelSet As AcadSelectionSet
Dim Filtertype(0) As Integer
Dim Filterdata(0) As Variant
Set BlockRefsSSet = CreateSelectionSet(ssetName, acDoc)
Filtertype(0) = 0: Filterdata(0) = "INSERT"
BlockRefsSSet.Select acSelectionSetAll, , , Filtertype, Filterdata
End Function
Function CreateSelectionSet(selsetName As String, Optional acDoc As Variant) As AcadSelectionSet
'returns a selection set with the given name
'if a selectionset with the given name already exists, it'll be cleared
'if a selectionset with the given name doesn't exist, it'll be created
Dim acSelSet As AcadSelectionSet
If IsMissing(acDoc) Then Set acDoc = ThisDrawing
On Error Resume Next
Set acSelSet = acDoc.SelectionSets.Item(selsetName) 'try to get an exisisting selection set
On Error GoTo 0
If acSelSet Is Nothing Then Set acSelSet = acDoc.SelectionSets.Add(selsetName) 'if unsuccsessful, then create it
acSelSet.Clear 'cleare the selection set
Set CreateSelectionSet = acSelSet
End Function
'-----------------------------------------------------------------
with following notes:
you can't have a colon (":") in a block name
so I used a hypen ("-") as its substitute
every block reference object will be attached the URL ("D:\Reports\File-nnn.pdf") associated with the block name it's a reference of
I want to use Excel to store "tag names" in column A and their associated "replacement text" in Column B. When the code runs, it needs to collect each tag, one at a time (row by row), search an entire Word document for those words, and replace them with their corresponding replacements.
I noticed the special tags in the headers and footers weren't being replaced. I turned to this article (http://word.mvps.org/faqs/customization/ReplaceAnywhere.htm) and found that working with a range of ranges (or cycling through all available Story Ranges in the document) I was able to do this.
I improved my code, as recommended in the link above and it worked, so long as my code was embedded in my "Normal" Word file, thereby using my VBA code from Word to operate on another Word document. However, the goal is to use VBA Excel to operate the replacements while reading an Excel file.
When I moved the code to Excel, I'm getting hung up on an Automation error which reads,
"Run-time error '-2147319779 (8002801d)': Automation error Library not registered.".
I've looked for answers from reviewing the Registry to using "Word.Application.12" in place of "Word.Application".
I have a Windows 7, 64-Bit machine, with Microsoft Office 2007. I have the following libraries selected:
Excel:
Visual Basic For Applications
Microsoft Excel 12.0 Object Library
OLE Automation
Microsoft Access 12.0 Object Library
Microsoft Outlook 12.0 Object Library
Microsoft Word 12.0 Object Library
Microsoft Forms 2.0 Object Library
Microsoft Office 14.0 Object Library
Word:
Visual Basic For Applications
Microsoft Word 12.0 Object Library
OLE Automation
Microsoft Office 12.0 Object Library
I have no issues with operating inside of Excel with regard to VBA. Normally, I will be passing a set of strings to this function, but for now, I have embedded the strings inside of the function, as if I am only planning on swapping one string (for any number of instances), with another predetermined string.
Function Story_Test()
Dim File As String
Dim Tag As String
Dim ReplacementString As String
Dim a As Integer
Dim WordObj As Object
Dim WordDoc As Object
Dim StoryRange As Word.Range
Dim Junk As Long
Dim BaseFile As String
'Normally, these lines would be strings which get passed in
File = "Z:\File.docx"
Tag = "{{Prepared_By}}"
ReplacementString = "Joe Somebody"
'Review currently open documents, and Set WordDoc to the correct one
'Don't worry, I already have error handling in place for the more complex code
Set WordObj = GetObject(, "Word.Application")
BaseFile = Basename(File)
For a = 1 To WordObj.Documents.Count
If WordObj.Documents(a).Name = BaseFile Then
Set WordDoc = WordObj.Documents(a)
Exit For
End If
Next a
'This is a fix provided to fix the skipped blank Header/Footer problem
Junk = WordDoc.Sections(1).Headers(1).Range.StoryType
'Okay, this is the line where we can see the error.
'When this code is run from Excel VBA, problem. From Word VBA, no problem.
'Anyone known why this is???
'***********************************************************************
For Each StoryRange In WordObj.Documents(a).StoryRanges
'***********************************************************************
Do
'All you need to know about the following function call is
' that I have a function that works to replace strings.
'It works fine provided it has valid strings and a valid StoryRange.
Call SearchAndReplaceInStory_ForVariants(StoryRange, Tag, _
ReplacementString, PreAdditive, FinalAdditive)
Set StoryRange = StoryRange.NextStoryRange
Loop Until StoryRange Is Nothing
Next StoryRange
Set WordObj = Nothing
Set WordDoc = Nothing
End Function
For Each StoryRange In WordObj.Documents(a).StoryRanges
should probably be
For Each StoryRange In WordDoc.StoryRanges
since you just assigned that in the loop above.
For now, I will have to conclude, as I don't have the possibility of testing the contrary, that there is a difference between using Microsoft Office 12 Object Library in one VBA environment, and Microsoft Office 14 Object Library in another. I don't have the means/authorizations to change either, so I must conclude, for now that is, that the difference between the two is the culprit. So, if I was to go forward and expect different results, I would assume Microsoft Office 12 Object Library to be the correct library, where 14 has a few differences that I am not aware of.
Thank you to all who provided input. If you have any other suggestions, we can discuss and forward. Thanks!
This is to update a bunch of links spread over body & Headers footers.
I didn't write this only from memory made a bunch of fixes, inclusions and tweaks.
It shows you how to cover all the different sections and can easily be modified to work within your parameters.
Please post your final code once done.
Public Sub UpdateAllFields()
Dim doc As Document
Dim wnd As Window
Dim lngMain As Long
Dim lngSplit As Long
Dim lngActPane As Long
Dim rngStory As Range
Dim TOC As TableOfContents
Dim TOA As TableOfAuthorities
Dim TOF As TableOfFigures
Dim shp As Shape
Dim sctn As Section
Dim Hdr As HeaderFooter
Dim Ftr As HeaderFooter
' Set Objects
Set doc = ActiveDocument
Set wnd = ActiveDocument.ActiveWindow
' get Active Pane Number
lngActPane = wnd.ActivePane.Index
' Hold View Type of Main pane
lngMain = wnd.Panes(1).View.Type
' Hold SplitSpecial
lngSplit = wnd.View.SplitSpecial
' Get Rid of any split
wnd.View.SplitSpecial = wdPaneNone
' Set View to Normal
wnd.View.Type = wdNormalView
' Loop through each story in doc to update
For Each rngStory In doc.StoryRanges
If rngStory.StoryType = wdCommentsStory Then
Application.DisplayAlerts = wdAlertsNone
' Update fields
rngStory.Fields.Update
Application.DisplayAlerts = wdAlertsAll
Else
' Update fields
rngStory.Fields.Update
End If
Next
'Loop through text boxes and update
For Each shp In doc.Shapes
With shp.TextFrame
If .HasText Then
shp.TextFrame.TextRange.Fields.Update
End If
End With
Next
' Loop through TOC and update
For Each TOC In doc.TablesOfContents
TOC.Update
Next
' Loop through TOA and update
For Each TOA In doc.TablesOfAuthorities
TOA.Update
Next
' Loop through TOF and update
For Each TOF In doc.TablesOfFigures
TOF.Update
Next
For Each sctn In doc.Sections
For Each Hdr In sctn.Headers
Hdr.Range.Fields.Update
For Each shp In Hdr.Shapes
With shp.TextFrame
If .HasText Then
shp.TextFrame.TextRange.Fields.Update
End If
End With
Next shp
Next Hdr
For Each Ftr In sctn.Footers
Ftr.Range.Fields.Update
For Each shp In Ftr.Shapes
With shp.TextFrame
If .HasText Then
shp.TextFrame.TextRange.Fields.Update
End If
End With
Next shp
Next Ftr
Next sctn
' Return Split to original state
wnd.View.SplitSpecial = lngSplit
' Return main pane to original state
wnd.Panes(1).View.Type = lngMain
' Active proper pane
wnd.Panes(lngActPane).Activate
' Close and release all pointers
Set wnd = Nothing
Set doc = Nothing
End Sub
I'm trying to create a small VB-application that removes the internal link in Word Documents, to their templates.
I have found this guide
http://word.tips.net/Pages/T001437_Batch_Template_Changes.html
and am trying to modify it, to use with VBA instead of Macro programming inside of Office.
However, I'm getting stuck on how to get the Document.Open to work. Any help is appreciated.
This is supposed to run as a free-standing application, and not runt from within Word.
I'm looking for a way to perform what the Macro does, but not from within Word.
There are two pieces of bad news to give here.
1) A document has to have a template. You cannot remove it, only change it to something else.
2) Changing a template does nothing anyway. See this page.
I am wonder if the problem with the Open method is that you are trying to open ".doc" extension files, not the modern ".docx" extension files. The VBA subroutine you linked to only does ".doc" files. This VBA code does both:
Function StringEndsWith( _
ByVal strValue As String, _
CheckFor As String) As Boolean
Dim sCompare As String
Dim lLen As Long
lLen = Len(CheckFor)
If lLen > Len(strValue) Then Exit Function
sCompare = Right(strValue, lLen)
StringEndsWith = StrComp(sCompare, CheckFor, vbTextCompare) = 0
End Function
Sub ChangeTemplates()
Dim strDocPath As String
Dim strTemplateB As String
Dim strCurDoc As String
Dim docCurDoc As Document
' set document folder path and template strings
strDocPath = "C:\tmp\"
' get first doc - only time need to provide file spec
strCurDoc = Dir(strDocPath & "*.doc*")
' ready to loop (for as long as file found)
Do While strCurDoc <> ""
If (StringEndsWith(strCurDoc, ".doc") Or StringEndsWith(strCurDoc, ".docx")) Then
' open file
Set docCurDoc = Documents.Open(FileName:=strDocPath & strCurDoc)
' change the template back to Normal
docCurDoc.AttachedTemplate = ""
' save and close
docCurDoc.Close wdSaveChanges
End If
' get next file name
strCurDoc = Dir
Loop
MsgBox "Finished"
End Sub
long time between answers but may be useful to others. If you have access to the VBE of the Word document [Alt F11], and you want to remove the reference then go to "Tools/References" [top menu] and deselect it from the list of reference files. I had a similar issue where template no longer existed, but it was still being 'referenced' in the Project window, so I did the above.