Add a bookmark in opened files and save them as dcox - vba

Question

I have a question about bookmarks. I made a macro that deletes all the bookmarks in a Word document and adds a new bookmark:
Sub AddBookmarkInCurrentFile()
'
' Deletes all the bookmarks in an already opened file
' and add one new bookmark in the file
'
' Deletes al current bookmarks
For Each bkm In ActiveDocument.Bookmarks
bkm.Delete
Next bkm
' Put Cursor add the beginning of the file and adds the bookmark
Selection.HomeKey Unit:=wdStory
ActiveDocument.Bookmarks.Add Name:="testBookmarkAdd"
MsgBox "Finished"
End Sub
When I run this it works fine.
Because I have to do this for more then 100 documents and save the *.doc as .docx I made a new version of the macro. Everything works accept the adding of the new bookmark. What is wrong in the code below?
Sub AddBookmarkInAllOpenedFiles()
' Opens all word files in a directory and deletes current bookmarks
' and adds one bookmark and saves the file to a docx file
Dim sSourcePath As String
Dim sTargetPath As String
Dim sDocName As String
Dim docCurDoc As Document
Dim sNewDocName As String
Dim sOrigName As String
Dim intPos As Integer
' Looking in this path
sSourcePath = "H:\Mijn Documenten\test\"
sTargetPath = "H:\Mijn Documenten\test\Converted\"
' Look for first DOC file
sDocName = Dir(sSourcePath & "*.doc")
Do While sDocName <> ""
' Repeat as long as there are source files
'Only work on files where right-most characters are ".doc"
If Right(sDocName, 4) = ".doc" Then
' Open file
Set docCurDoc = Documents.Open(FileName:=sSourcePath & sDocName)
' Deletes all the bookmarks
For Each bkm In ActiveDocument.Bookmarks
bkm.Delete
Next bkm
' Put Cursor add the beginning of the file and adds the bookmark
Selection.HomeKey Unit:=wdStory
ActiveDocument.Bookmarks.Add Name:="testBookmarkAdd"
'Saves the document as a docx
sNewDocName = Replace(sDocName, ".doc", ".docx")
With docCurDoc
.SaveAs FileName:=sTargetPath & sNewDocName, _
FileFormat:=wdFormatDocumentDefault
.Close SaveChanges:=wdDoNotSaveChanges
End With
End If
' Get next source file name
sDocName = Dir
Loop
MsgBox "Finished"
End Sub

Answer 1

Try:
Sub BookmarkAllFilesInFolder()
' Opens all word files in a directory and deletes current bookmarks
' and adds one bookmark and saves the file to a docx file
Dim sSourcePath As String, sTargetPath As String
Dim sDocName As String, docCurDoc As Document
' Looking in this path
sSourcePath = "H:\Mijn Documenten\test\"
sTargetPath = sSourcePath & "Converted\"
' Look for first DOC file
sDocName = Dir(sSourcePath & "*.doc")
' Repeat as long as there are source files
Do While sDocName <> ""
' Only open .doc files"
If Right(sDocName, 4) = ".doc" Then
' Open file
Set docCurDoc = Documents.Open(FileName:=sSourcePath & sDocName, AddToRecentFiles:=False, Visible:=False)
With docCurDoc
'Delete all existing bookmarks
While .Bookmarks.Count > 0
.Bookmarks(1).Delete
Wend
'Add our bookmark
.Bookmarks.Add Name:="TestBookmark", Range:=.Range(0, 0)
'Save the file in .docx format to the output folder
.SaveAs2 FileName:=sTargetPath & sDocName & "x", _
FileFormat:=wdFormatDocumentDefault, AddToRecentFiles:=False
.Close SaveChanges:=wdDoNotSaveChanges
End With
End If
' Get next source file name
sDocName = Dir
Loop
Set docCurDoc = Nothing
MsgBox "Finished"
End Sub