Outlook macro to save emails in a specific folder based on a msgbox popup

[carly]

Hi All,

I found a macro online which I’m trying to use to save the email to a folder within a specified directory. The folders are numbers either 4 or 5 digits like 5100 for example.

The macro isn’t finding the destination folder, even when I’ve changed it to c:\test and created a folder etc and tried different network directories.

Any ideas?

Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean
    ' Returns True if the passed sPathName exist Otherwise returns False
    On Error Resume Next
    If sPathName <> "" Then
        If IsMissing(Directory) Or Directory = False Then
            File_Exists = (Dir$(sPathName) <> "")
        Else
            File_Exists = (Dir$(sPathName, vbDirectory) <> "")
        End If
    End If
End Function
 
Sub SaveAsMSG()
    Dim myItem As Outlook.Inspector
    Dim objItem As Object
    PathName = "\\myserver\folder\"
    Set myOlApp = CreateObject("Outlook.Application")
    Set myItem = myOlApp.ActiveInspector
    If Not TypeName(myItem) = "Nothing" Then
        Set objItem = myItem.CurrentItem
        StrSub = objItem.Subject
        StrName = InputBox("Folder number...")
        Do While File_Exists(PathName & StrName & "\Emails\", True) = False
            StrName = InputBox("Folder does not exist, give a new number...", "new folder number")
        Loop
        Do While File_Exists(PathName & StrName & "\Emails\" & StrSub & ".msg") = True
            StrSub = InputBox("File exists, give a new file name...", "new file name", StrSub)
        Loop
        objItem.SaveAs PathName & StrName & "\Emails\" & StrSub & ".msg", olMSG
    Else
        MsgBox "There is no current opened email item."
    End If
End Sub