Saving a backup copy of Project file to a specified path in VBA

[Grizz]

Hi,

I am fairly familiar with Excel VBA but not so much with Project.

With some of my Excel files I have a VBA routine to save a backup copy of the file:

Public Sub Workbook_BeforeClose(Cancel As Boolean)


    Application.DisplayAlerts = False
    Dim MyBackupPath As String


    MyBackupPath = "C:\Backups\"


    ActiveWorkbook.SaveCopyAs MyBackupPath & Format(Now, "dd.mm.yy - h.mm AM/PM") & " - " & Application.UserName & " " & ActiveWorkbook.Name
    If ThisWorkbook.Saved = False Then
    ThisWorkbook.Save
    End If
    Application.DisplayAlerts = True
End Sub

I would like to do the same with a MS Project file but after having changed the obvious "ActiveWorkbook" to "ActiveProject" I'm still getting runtime errors on that line.

Please can anyone point out what I'm doing wrong?

Thanks

[itConsultant]

Hi,

i don't know whether it is still relevant for you.

Here is how i did it:

Navigate to the Visual Basic editor and add the before_close method inside of "ThisProject"

Private Sub Project_BeforeClose(ByVal pj As Project)

Dim targetFolder As String
targetFolder = "\\server\xyz"

If Not Application.ActiveProject.Saved Then Exit Sub

If LCase(Application.UserName) = "myuser" Then    
    
    Dim answer As Integer
    
    answer = MsgBox("Do you want to copy the ActiveProject to the following network share? " & vbNewLine & vbNewLine & targetFolder, vbYesNo + vbQuestion, "Copy file to network share")
    
    If answer = vbYes Then
        
        copyFile Application.ActiveProject.FullName, targetFolder
        
    End If

End If

End Sub

Put this anywhere inside of a module:

Sub copyFile(ByVal fileUrl As String, ByVal targetFolder As String)

Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String

sFile = getFilenameFromPath(fileUrl)
sSFolder = Replace(fileUrl, getFilenameFromPath(fileUrl), "")
sDFolder = targetFolder

If isFile(sDFolder & sFile) Then Kill sDFolder & sFile

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FileExists(sSFolder & sFile) Then
    FSO.copyFile (sSFolder & sFile), sDFolder, True
End If

End Sub

Public Function isFile(ByVal fName As String) As Boolean 'Returns TRUE if the provided name points to an existing file. Returns FALSE if not existing, or if it's a folder

On Error Resume Next
isFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)

End Function

Public Function getFilenameFromPath(ByVal strPath As String) As String ' Returns the rightmost characters of a string upto but not including the rightmost '\' -> e.g. 'c:\winnt\win.ini' returns 'win.ini'

Dim separator As String
separator = "\"

If strPath Like "http*" Then
    separator = "/"
End If

If Right$(strPath, 1) <> separator And Len(strPath) > 0 Then
    getFilenameFromPath = getFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If

End Function

Have fun!

Merry christmas to ya all.



Best regards from Germany

Joerg

[itConsultant]

P.S.: "File save as" must look like:

FileSaveAs Name:="C:\temp\file.mpp", FormatID:="MSProject.MPP"

and just save is:

FileSave