User Tools

Site Tools


windows:office_macros

This is an old revision of the document!


Microsoft Office Macros

Word

Increment and Save

Increment revN in the filename of the current file and save it.

IncrAndSave.vba
Sub IncrAndSave()
'
' Increment the revision number and save
'
'    ActiveDocument.Name
    Dim myfilename, currentfilename, nstr, newno, x, y, z As String
    Dim a, b, c, n As Integer
    Dim rev As Boolean
 
    ' this strips the extension from the filename
    currentfilename = CreateObject("scripting.filesystemobject").getbasename(ActiveDocument.Name)
    Set Regexp = CreateObject("VBScript.RegExp")
    Regexp.Pattern = "[0-9]+$"
    Set Matches = Regexp.Execute(currentfilename)
    rev = False
    For Each Match In Matches
        rev = True
        n = Match
        nstr = Match
    Next
    If rev Then
        myfilename = Mid(currentfilename, 1, Len(currentfilename) - Len(nstr))
        newno = n + 1
        myfilename = ActiveDocument.Path & "\" & myfilename & newno
'       MsgBox "Saving current file to " & myfilename
    Else
        myfilename = ActiveDocument.Path & "\" & currentfilename & " rev1"
    End If
    ActiveDocument.SaveAs filename:=myfilename, FileFormat:= _
            wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
            :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
            :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
            SaveAsAOCELetter:=False
End Sub

Save a copy-edited version to a pre-defined folder

SaveCopyEdit.vba
Sub SaveCopyEdit()
'
' SaveCopyEdit Macro
'
'
'    ActiveDocument.Name
    Dim myfilename As String
    myfilename = "D:\slack\rwanda\copy edit\" & CreateObject("scripting.filesystemobject").getbasename(ActiveDocument.Name) & " revDH.docx"
'    MsgBox myfilename
    Application.StatusBar = "Saving to copy edit folder..."
    ActiveDocument.SaveAs filename:=myfilename, FileFormat:= _
        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    ActiveDocument.SaveAs
    ActiveDocument.TrackRevisions = True
'    ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions
End Sub
windows/office_macros.1466005525.txt.gz · Last modified: 2019/11/07 17:58 (external edit)