Macro suddenly stopped working.

[Kilroy]

This macro has been working for the last year. I'm not sure what the heck is going on. It gets to the second last line "Documents.Open strOriginal" which it does complete but stops after doing so. I'm using an ACER laptop now. I have had to change other macros for use on this machine but I can't figure out why this one won't finish. Any ideas? second issue I'm having is that the documents are from a folder that asks if you want to open the document as read only so when it reopens the document it doesn't ask it just opens it as read only. There is no password protection. An help appreciated.




Sub SaveBackUpCopy()
Application.ScreenUpdating = False
Const strPath As String = "C:\Users\useyourownname\Desktop\in process documents\misc\backups\" 'the path to save the copy
Dim lFmt As Long
Dim strOriginal As String
With ActiveDocument
.Save
If .Path = "" Then
MsgBox "The document must be saved first!"
Exit Sub
End If
lFmt = .SaveFormat
strOriginal = .FullName
'.AcceptAllRevisions
.TrackRevisions = False
With ActiveWindow.View.RevisionsFilter
.Markup = wdRevisionsMarkupNone
.View = wdRevisionsViewFinal
With ActiveDocument
.Save
End With
End With
.SaveAs2 FileName:=strPath & Chr(32) & .Name, _
fileFormat:=lFmt, _
AddToRecentFiles:=False
.Close 0
End With
Documents.Open strOriginal
Application.ScreenUpdating = True
End Sub

[gmayor]

It seems OK and works here, but there is no need to close the document and re-open the original, just save it again with the original name, and you can define the actual folder for the user and ensure that it is present e.g.


Option Explicit

Sub SaveBackUpCopy()
Dim strPath As String
Dim lFmt As Long
Dim strOriginal As String
strPath = Environ("USERPROFILE") & "\Desktop\in process documents\misc\backups\"
CreateFolders strPath

Application.ScreenUpdating = False
With ActiveDocument
.Save
If .path = "" Then
MsgBox "The document must be saved first!"
Exit Sub
End If
lFmt = .SaveFormat
strOriginal = .FullName
'.AcceptAllRevisions
.TrackRevisions = False
With ActiveWindow.View.RevisionsFilter
.Markup = wdRevisionsMarkupNone
.View = wdRevisionsViewFinal
With ActiveDocument
.Save
End With
End With
.SaveAs2 FileName:=strPath & .Name, _
fileFormat:=lFmt, _
AddToRecentFiles:=False
.SaveAs2 FileName:=strOriginal, _
fileFormat:=lFmt, _
AddToRecentFiles:=False
End With
Application.ScreenUpdating = True
End Sub

Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lng_Path As Long
Dim VPath As Variant
Dim oFSO As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
VPath = Split(strPath, "\")
If Left(strPath, 2) = "\\" Then
strPath = "\\" & VPath(2) & "\"
For lng_Path = 3 To UBound(VPath)
strPath = strPath & VPath(lng_Path) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lng_Path
Else
strPath = VPath(0) & "\"
For lng_Path = 1 To UBound(VPath)
strPath = strPath & VPath(lng_Path) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lng_Path
End If
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function

[Kilroy]

Graham thank you so much! Works perfectly and solves both problems. Much appreciated.

[macropod]

This macro has been working for the last year. I'm not sure what the heck is going on. It gets to the second last line "Documents.Open strOriginal" which it does complete but stops after doing so.
MS has put out a Word update that's killing macros at the Documents.Open point, and another that's supposed to fix it...

[Kilroy]

....another that's supposed to fix it...

Sure didn't help my macros