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