none
"Save as PDF only macro" for MS word and MSexcel RRS feed

  • Question

  • Hi,

    I know very little or nothing about macros, but I copied and adjusted the ones below from various blogs.  It is about 90% effective in what I want to achieve except for a few things, as I will explain later.

    I work in the quality division of an educational institution and we need all staff to be able to complete documents (and spread sheets) on-line, but they may only be allowed to save their work in PDF format (so as not to overwrite the Word or Excel template) and they must also be "forced" to select a folder on their hard-drive so as not to save in the default server location.

    A number of imperatives:

    1. Saving changes to the "blank templates" must be prevented by means of "Control S", "Save", "the Auto-close X-button", "Save as Word document, or Word 97-2003, or any other format (except PDF)"

    2. Saving only as PDF must be allowed

    3. Changes to the original template must be discarded when closing the work.

    4. A folder on their local disc must be selected.

    The macros below work to varying degrees of success and I would appreciate if these can be adjusted to suit. 

    Msword:

    This one works perfectly, except if they select "Save as" and then access the "Save as" menu, they can still select formats other than PDF (including the format of the original document)


    Sub FileSaveAs()

    Dim StrPath As String, StrName As String, Result
    With ActiveDocument
      On Error GoTo Errhandler
      StrPath = GetFolder & "\"
      StrName = Split(.Name, ".")(0)
      While Dir(StrPath & StrName & ".pdf") <> ""
        Result = InputBox("WARNING - A file already exists with the name:" & vbCr & _
          Split(.Name, ".")(0) & vbCr & _
          "You may edit the filename or continue without editing." _
          & vbCr & vbTab & vbTab & vbTab & "Proceed?", "File Exists", StrName)
        If Result = vbCancel Then Exit Sub
        If StrName = Result Then GoTo Overwrite
        StrName = Result
      Wend
    Overwrite:
      .ExportAsFixedFormat OutputFileName:=StrPath & StrName & ".pdf", _
      ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
      OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
      Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
      CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
      BitmapMissingFonts:=True, UseISO19005_1:=False
    End With
    Errhandler:
    End Sub
     
    Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
    End Function
    Sub FileSave()

    End Sub

    Sub AutoClose()
           
            ActiveDocument.Saved = True

    End Sub

     

    MSexcel:

    This one works perfectly well, except it does not force the selection of a folder on the local drive.

    New macros module:

    Sub SaveRoutine()
       
        On Error GoTo ReEnable
        Application.EnableEvents = False
        Dim strPath As String
        Dim strFileName As String
       
        strPath = "C:\Users\User\Documents\Excel\Test Macros\"
       
        strFileName = "Test Before Save Routine " & Format(Date, "yyyy-mm-dd") & ".xlsm"
           
        Application.DisplayAlerts = False    'Optional
       
        ThisWorkbook.SaveAs Filename:= _
                strPath & strFileName, _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
                CreateBackup:=False
               
        MsgBox "Saved as: " & ThisWorkbook.FullName
     
    ReEnable:
         Application.DisplayAlerts = True    'Optional
         Application.EnableEvents = True
    End Sub
    Sub Auto_Close()
            ThisWorkbook.Saved = True
            ActiveWorkbook.Close savechanges:=False
    Application.EnableEvents = False
    End Sub

    This workbook:

    Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
         On Error GoTo ReEnableEvents
         Application.EnableEvents = False
         Cancel = True
         Call SaveRoutine
    ReEnableEvents:
         Application.EnableEvents = True
     End Sub

    I will be on leave from 26 August to 6 September and will hence only be able to test and respond to your help by 9 September 2013

    Thank you

    Danie Bezuidenhout

    Thursday, August 22, 2013 9:53 AM

Answers

  • Hi Danie

    You won't get any answer to questions about Excel in the Word forum. It will make this discussion more readable if you remove that information from your post.

    I recommend you consider using true templates (*.dot), rather than re-using documents. Then you won't have any worries about changes being saved back to the original file. When the user double-clicks on a template file in Windows or uses the "New" command in the Office application, a copy is made of the template as a new document.

    You don't mention the version of Office you're targeting, but the approach with Sub FileSave or Sub FileSaveAs will not work in recent versions of Word. In order to re-purpose these commands, looking forward to version 2013, you need to work with the DocumentBeforeSave event. And it would probably also be a good idea to use the FileDialog functionality so that you can present the user with exactly what he should be allowed to use and force him to select a different folder.


    Cindy Meister, VSTO/Word MVP, my blog

    Thursday, August 22, 2013 2:59 PM
    Moderator