Consulting

Results 1 to 5 of 5

Thread: Macro suddenly stopped working.

  1. #1
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location

    Macro suddenly stopped working.

    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
    Last edited by Kilroy; 08-14-2018 at 05:25 AM.

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    Graham thank you so much! Works perfectly and solves both problems. Much appreciated.

  4. #4
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by Kilroy View Post
    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...
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  5. #5
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    Quote Originally Posted by macropod View Post
    ....another that's supposed to fix it...
    Sure didn't help my macros

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •