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.
Related
I've tried to use the below code which I found on this conversation How To Search And Replace Across Multiple Files In Word? supplied by Charles Kenyon. However, it doesn't seem to work for me. I've enabled macros on my word and added the below code as a new module in Macros. When I go to replace all, it'll replace the text as per normal, but after doing this, when I open up the other macros enabled word doc, I find that the same text is still in these docs, without being replaced. Am I doing something wrong? Namely, I also wish to add a wildcard entry into my replace all, will the below code work or can someone suggest a better alternative? I have tested the below code with and without wildcard entries to no avail. I've also tried the code on this page in my macros but it also didn't work How to find and replace a text in multiple Word documents using VBAThanks for any help!
Option Explicit
Public Sub BatchReplaceAll()
Dim FirstLoop As Boolean
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim Response As Long
PathToUse = "C:\Test\"
'Error handler to handle error generated whenever
'the FindReplace dialog is closed
On Error Resume Next
'Close all open documents before beginning
Documents.Close SaveChanges:=wdPromptToSaveChanges
'Boolean expression to test whether first loop
'This is used so that the FindReplace dialog will
'only be displayed for the first document
FirstLoop = True
'Set the directory and type of file to batch process
myFile = Dir$(PathToUse & "*.doc")
While myFile <> ""
'Open document
Set myDoc = Documents.Open(PathToUse & myFile)
If FirstLoop Then
'Display dialog on first loop only
Dialogs(wdDialogEditReplace).Show
FirstLoop = False
Response = MsgBox("Do you want to process " & _
"the rest of the files in this folder", vbYesNo)
If Response = vbNo Then Exit Sub
Else
'On subsequent loops (files), a ReplaceAll is
'executed with the original settings and without
'displaying the dialog box again
With Dialogs(wdDialogEditReplace)
.ReplaceAll = 1
.Execute
End With
End If
'Close the modified document after saving changes
myDoc.Close SaveChanges:=wdSaveChanges
'Next file in folder
myFile = Dir$()
Wend
End Sub
It is easy to find in the internet a way of write into a txt file but all I find is always writing in the very last line:
Sub write_log(sentence_to_be_written As String)
Dim strFile_Path As String
strFile_Path = "C:\Users\[user_name]\Desktop\log.txt"
Open strFile_Path For Append As #1
Print #1, Now() & " --> " & sentence_to_be_written
Close #1
End Sub
I would like to write instead into the first line of the txt file.
Try the next code, please. It needs a reference to Microsoft Scripting Runtime. It can be adapted to work without such a reference. In fact, I will also post a pice of code able to automatically add the necessary reference... It is possible to read the text using standard VBA Open, but only concatenating line by line and I think this solution is more elegant:
Sub write_log_OnTop(sentence_to_be_written As String)
'It neds a reference to 'Microsoft Script Runtime'
Dim strFile_Path As String, strText As String
Dim fso As New FileSystemObject, txtStr As TextStream
strFile_Path = "C:\Users\Fane Branesti\OneDrive\Desktop\log.txt"
If Dir(strFile_Path) <> "" Then 'check if file exists
Set txtStr = fso.OpenTextFile(strFile_Path)
strText = txtStr.ReadAll
txtStr.Close
Else
MsgBox "Wrong file path...": Exit Sub
End If
strText = Now() & " --> " & sentence_to_be_written & vbCrLf & strText
Open strFile_Path For Output As #1
Print #1, strText
Close #1
End Sub
And Microsoft Scripting Runtime reference can be automatically add by running of the next code:
Private Sub Add_Scripting_Reference() 'Adds 'Microsoft Scripting Runtime'
Dim wb As Workbook, r As Reference
Set wb = ThisWorkbook
For Each r In wb.VBProject.References
If r.name = "Scripting" Then Exit Sub
Next
wb.VBProject.References.AddFromFile Environ("windir") & "\system32\scrrun.dll"
End Sub
If you do not want the reference, even if I would not understand such a choice, it is enough to comment/replace the code line
Dim fso As New FileSystemObject, txtStr As TextStream
with:
Dim fso As Object, txtStr As Object: Set fso = CreateObject("Scripting.FileSystemObject")
There is no command to add text at the top (or the middle) of any file. I never heard about such command in any programming language. It's about (disk-)space management, if you add a line of text in front of any other text, the existing text needs to be moved, and this is a rather complicated operation.
If you deal with short files, you could solve that by reading the content of the file into memory and then recreate the file by first writing the new line(s) and the add the content - as Joerg Wood suggested in the comments. However, this would need lot of memory and/or disk IO if the file gets larger, and the process has to be repeated every time you want to add a line - maybe not an issue if you write only one line per hour, but quite an issue if you are writing multiple lines per second.
It seems you are writing a log file and probably you want to see what was going on lately. You could use a windows version of the tail command (that comes from Unix) or use the powershell command Get-Content "C:\Users\[user_name]\Desktop\log.txt" -Tail 10 (see https://stackoverflow.com/a/188126/7599798) for that - it will display the last lines of a file.
An alternative could be to write the log into an Excel sheet or a database - in both cases it is easy to fetch the data in any order.
I am having trouble coding this VBA Macro for a bunch of CSV files (10000). After searching I found/used this for my code:
Loop through files in a folder using VBA? . It doesn't seem to work and I'm not sure why... I have tried the While loop but it is very slow I don't know if it can finish running.
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("C:\Users\me\Desktop\test")
While (file <> "")
If InStr(file, "test") > 0 Then
'// my macro code is here
Exit Sub
End If
file = Dir
Wend
End Sub
What else should I try changing? Where did I go wrong? I have also tried using this code https://www.thespreadsheetguru.com/the-code-vault/2014/4/23/loop-through-all-excel-files-in-a-given-folder but am unsure what else to change besides the directory and the 'Change First Worksheet's Background Fill Blue.
Also tried this http://www.ozgrid.com/VBA/loop-through.htm which seems pretty fool proof but I cant get it to work...
UPDATES FROM L8N
Option Explicit
Sub looper()
Dim fso As Scripting.FileSystemObject
Dim aFolder As Scripting.Folder
Dim aFile As Scripting.file
Dim aText As Scripting.TextStreame
Dim singleLine As String
Set fso = New FileSystemObject
Set aFolder = fso.GetFolder("C:\Users\ME\Desktop\test") 'set path to the folder that contains the files
For Each aFile In aFolder.Files 'loops through every file in the top level of the folder
If InStr(1, vbBinaryCompare) > 0 Then
Range("A2:D200210").Clear 'what i want to happen to every file
Set aText = fso.OpenTextFile(aFile.Path, ForReading)
Do Until aText.AtEndOfStream
singleLine = aText.ReadLine 'read line into string, every call advances the line counter by one, this prevents skipping lines
If InStr(1, singleLine, vbBinaryCompare) > 0 Then Debug.Print singleLine ' in line case, prints line if target value is found
Loop
End If
Next aFile
Debug.Print "finished"
End Sub
It runs, but it does not seem to implement the changes I want (Range("A2:D200210").Clear ) to each file. Also the string name for my code does not matter, the info in the sheet does not either. My original code was to test if it looped at all.
I don't know exactly what you are trying to do, the code you have does the following:
file = Dir("C:\Users\me\Desktop\test") writes the filename to file if the file "test" exists, if you use Dir("C:\Users\me\Desktop\test\") the function will return the name of the first file it finds.
On subsequent runs it will return the next file in the folder, keep in mind that this is a global call, so if you call the function somewhere else it may interfere. Using the Microsoft Scripting Engine Runtime is preferable in most cases apart from quick checks if a file exists.
If InStr(file, "test") > 0 Then You test if "test" is a part of the filename, so far so good, but keep in mind to tell InStr how it should compare the two strings. InStr accepts four parameters (all of them optional), be sure to pass the proper ones. The microsoft documentation is actually quite decent.
Is this what you wanted? I think you might be looking for something inside the .csv file, if so I can extend the script below.
A simple way to loop though all files in a folder is attached below:
Option Explicit
Sub looper()
Dim fso As Scripting.FileSystemObject
Dim aFolder As Scripting.Folder
Dim aFile As Scripting.file
Dim aText As Scripting.TextStream
Dim targetName As String 'string that identifies files
Dim targetWord As String 'string that identifies line inside csv file
Dim singleLine As String
Set fso = New FileSystemObject
Set aFolder = fso.GetFolder("C:\Users\Me\Desktop\test") 'set folder that contains the files
targetName = "someFileName"
targetWord = "someString"
For Each aFile In aFolder.Files 'loops through every file in the top level of the folder
If InStr(1, aFile.Name, targetName, vbBinaryCompare) > 0 Then
Debug.Print "Found a matching File: "; aFile.Name
Set aText = fso.OpenTextFile(aFile.Path, ForReading)
Do Until aText.AtEndOfStream
singleLine = aText.ReadLine 'read line into string, every call advances the line counter by one, this prevents skipping lines
If InStr(1, singleLine, targetWord, vbBinaryCompare) > 0 Then Debug.Print singleLine ' in line case, prints line if targer value is found
Loop
End If
Next aFile
Debug.Print "finished"
End Sub
Bonus Info:
Use option explicit to make sure all variables are declared properly
Edit:
Not able to add comments to your post yet, so I'll put the response here.
If InStr(1, vbBinaryCompare) > 0 Then this line is now broken as it will always return 0. If you want to loop through every file just omit the IF-Contitional or set it to If True Then.
Range("A2:D200210").Clear is a so called implicit reference, the Range Object refers to the "Global" Worksheet. Every time this piece of code is executed, the change happens on the "Global" Worksheet, a nice answer by Mathieu Guindon from just recently explains this.
It runs, but it does not seem to implement the changes I want (Range("A2:D200210").Clear ) to each file. Also the string name for my code does not matter, the info in the sheet does not either. My original code was to test if it looped at all.
So from what I can see you try to delete everything but the first row inside a .csv file. A .csv file is not a worksheet(even though you can import it into excel), so you can't use the Range property.
Fortunately, there is an even easier way to do this, just use the Microsoft Scripting Runtime to edit the .csv file.
Set aText = aFile.OpenAsTextStream(ForReading) ' open file in read mode
singleLine = aText.ReadLine ' read the first line and store it
Set aText = aFile.OpenAsTextStream(ForWriting) ' open file in write mode
aText.Write (singleLine) 'write the line you saved before
Or even more compact:
aFile.OpenAsTextStream(ForWriting).Write aFile.OpenAsTextStream(ForReading).ReadLine 'overwrites the file with what was written in the first line.
The advantage with the longer code is the ability to use the string somewhere else, for example storing it somewhere in your workbook.
I have a lot of Excel documents in a directory. New files are added to the directory all the time, but they need to be renamed using a specific file name pattern (the procedure RenameFile below does this). To solve this I have to iterate through all excel documents and rename only the documents that haven't been renamed earlier.
The problem is that I can't determine if a file has been renamed already. I have an idea that I should mark/tag the document as "renamed" in some way. Well, it's easy if I open each document and set a Document Property or other hidden variable. But that solution would force me to open each document in the directory to see if the property is defined, and then close it again and move on to next. This is too time consuming...
What I need is a method to tag/mark/flag each renamed document in some way. This tag/mark/flag must be accessible without opening the document. Any ideas?
Sub RenameExcelFiles(InFolder As String)
Dim ExcelFile As String
ExcelFile = Dir(InFolder & "\*.xlsx")
Do While ExcelFile <> ""
If Not ExcelFileHasProperty("Is already renamed") Then
RenameFile ExcelFile ' My own rename function
SetExcelFileProperty "Is already renamed"
End If
' Fetch Next Excel file...
ExcelFile = Dir()
Loop
End Sub
Best case scenario solution (that I can think of) - your excel function could be quite unique - e.g. ending on _renamedYYYYMMMDDHHMMSS.
Then, simply split the filename by _ and check whether it contains the word _renamed*. Like this:
Public Sub TestMe()
Dim name As String
name = "someName_renamed2018FEB02122755"
Dim newName As String
newName = Split(name, "_")(UBound(Split(name, "_")))
If InStr(newName, "renamed") Then
Debug.Print "Document is renamed!"
End If
End Sub
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