Sub CopyFile()
Set fs = CreateObject("Scripting.FileSystemObject")
filetoopen = Application.GetOpenFilename("Outlook Files (*.msg), *.msg")
If filetoopen <> False Then
fPath = Left(filetoopen, InStrRev(filetoopen, "\"))
fname = Right(filetoopen, Len(filetoopen) - Len(fPath))
Newpath = fPath
If Right(Newpath, 1) <> "\" Then Newpath = Newpath & "\"
Newname = Left(fname, Len(fname) - 4) & "_New.msg"
fs.CopyFile filetoopen, Newpath & Newname
End If
End Sub