Outlook File Request System Using VBA

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()

Dim objNS As Outlook.NameSpace
  Set objNS = GetNamespace("MAPI")
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

' -------------------------------------------------------------------
' File Request System v1.0
' code by Jimmy Pena, 4-4-2008
' http://www.codeforexcelandoutlook.com
'
' To request a file, subject should be:
' Subject: FILEGET C:\MyFile.doc
'
' To send a file to a folder, subject should be:
' Subject: FILEPUT C:\
' 1. There should be at least one attachment
' 2. All attachments will be saved to the same folder
'
' Scripting Runtime object library is late-bound, you can change
' to early-bound by: a) Add a reference to the Scripting Runtime
' object library in Tools>References of the VBE
' b) Change "Dim fso As Object" to
' "Dim fso As Scripting.FileSystemObject"
' c) Change
' "Set fso = CreateObject("Scripting.FileSystemObject")" to
' "Set fso = New Scripting.FileSystemObject"
' -------------------------------------------------------------------

If TypeName(item) = "MailItem" Then
    Dim ToDo As String
    Dim WhatAndWhere As String
    Dim Msg As Outlook.MailItem
    Dim MsgAttach As Outlook.Attachments
    Dim MsgReply As Outlook.MailItem
    Dim SlashSign As Long
    Dim sPath As String
    Dim sFile As String
    Dim fso As Object
    Dim UserN As String
    Dim DeskTopSharedFolder As String
    Dim strHelpText As String

    Const strNoFolder As String = "Error: That folder does not " & _
    "exist, please resubmit with a valid folder name."
    Const strNoFilename As String = "Error: The filename should " & _
    "not be in the subject line. Please resubmit."
    Const strNoAttach As String = "Error: I'm sorry, there does " & _
    "not appear to be any attachments to your email. " & _
    "Please resend your request with the attachments you want saved."
    Const strBadSubject As String = "Error: I don't understand that " & _
    "subject. Please try again."
    Const strNoAccess As String = "Error: That folder cannot be " & _
    "accessed. Please choose another folder and try again."
    Const strNoFile As String = "Error: File doesn't exist. " & _
    "Please check the folder name and spelling."
    
    Set Msg = item

    ' get current username so we can figure out the desktop folder name
    UserN = Environ("username")
    DeskTopSharedFolder = "C:\Documents And Settings\" & _
    UserN & "\Desktop\Shared\"

    On Error Resume Next
    ToDo = Left$(Msg.Subject, 7)
    WhatAndWhere = Right$(Msg.Subject, Len(Msg.Subject) - 8)
    On Error GoTo 0

Select Case Msg.Subject
    Case "FILEGET HELP", "FILEPUT HELP", "FILE GET HELP", "FILE PUT HELP", _
 "fileget help", "fileput help", "file get help", "file put help"
    strHelpText = "Welcome to the File Request System!"
    strHelpText = strHelpText & vbCr & vbCr & "To request a file:"
    strHelpText = strHelpText & vbCr & _
"Send a blank email with "FILEGET drive:path\filename" in the subject. (without quotes)"
    strHelpText = strHelpText & vbCr & _
"Where 'drive:path\filename' is the full path and filename of the file you want."
    strHelpText = strHelpText & vbCr & "Ex: FILEGET E:\MyFolder\MyFile.doc"
    strHelpText = strHelpText & vbCr & vbCr & "To send a file:"
    strHelpText = strHelpText & vbCr & _
"Send a blank email with "FILEPUT [path]" in the subject. (without quotes)"
    strHelpText = strHelpText & vbCr & _
"There should be at least one attachment. All files will be placed in the folder you specify."
    strHelpText = strHelpText & vbCr & "Ex: FILEPUT D:\"
    strHelpText = strHelpText & vbCr & vbCr & _
"To request this help text, send a blank email with " & _
"FILEGET HELP" or "FILEPUT HELP" in the subject."

        Call SendMsg(Msg, strHelpText, , Msg.Subject)
        GoTo ExitProc
End Select
    
    If (ToDo <> "FILEGET") And (ToDo <> "FILEPUT") Then
        GoTo ExitProc
    End If

    Select Case ToDo
        Case "FILEGET", "fileget"
        
            ' check for valid folder/file name
            ' if there is no backslash, it has to be malformed
            
            SlashSign = InStrRev(WhatAndWhere, "\")
            If SlashSign = 0 Then
                Call SendMsg(Msg, strBadSubject, , ToDo)
                GoTo ExitProc
            End If
            
            ' test the path to make sure it is valid, and
            ' that it isn't the C:\ drive (except for special desktop\shared folder
            ' where we allow users to place files they want to share
            
            sPath = Left$(WhatAndWhere, SlashSign)
            If (Left$(sPath, 3) = "C:\") Or (Left$(sPath, 3) = "c:\") Then
                If sPath <> DeskTopSharedFolder Then
                    Call SendMsg(Msg, strNoAccess, , ToDo)
                    GoTo ExitProc
                End If
            End If
    
            ' check if path & file exists!
            Set fso = CreateObject("Scripting.FileSystemObject")
           
            sFile = Right$(WhatAndWhere, Len(WhatAndWhere) - SlashSign)
            
            If fso.FileExists(sPath & sFile) = False Then
                ' file doesn't exist
                ' send err msg to requestor
                Call SendMsg(Msg, strNoFile, , ToDo)
                GoTo ExitProc
            End If
            
            Call FileServ(Msg, ToDo, WhatAndWhere)

'---------------------------------------------------------------------
' what to do with orig msg?
' a) to simply mark as read, uncomment this line of code:
'
' Msg.UnRead = False
'
' b) to move to a folder, uncomment this section of code:
'
'Dim MoveFolder As Outlook.MAPIFolder
'Dim olApp As Application
'Dim olNS As NameSpace
'On Error Resume Next
'    Set olApp = Application
'    Set olNS = olApp.GetNamespace("MAPI")
'    Set MoveFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("File Requests")
'On Error GoTo 0
'
'If MoveFolder = Nothing Then
'    Set MoveFolder = olNS.GetDefaultFolder(olFolderInbox).Folders.Add("File Requests")
'End If
'
'With Msg
'.UnRead = False
'.Move MoveFolder
'End With
'---------------------------------------------------------------------

        Case "FILEPUT", "fileput"
            ' if the filename is in the path, 
            ' the fourth to last character will be a period
            If Mid$(WhatAndWhere, Len(WhatAndWhere) - 3, 1) = "." Then
                ' filename was in the path
                ' send err msg to requestor
                Call SendMsg(Msg, strNoFilename, , ToDo)
                GoTo ExitProc
            End If

            ' check for valid folder
            If Right$(WhatAndWhere, 1) <> "\" Then
                WhatAndWhere = WhatAndWhere & "\"
            End If
            
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FolderExists(WhatAndWhere) = False Then
            ' bad folder in subject line
                Call SendMsg(Msg, strNoFolder, , ToDo)
                GoTo ExitProc
            End If

            ' the file(s) should be attached, if not, exit
            Set MsgAttach = Msg.Attachments
            If MsgAttach.Attachments.Count > 0 Then
                Call FileServ(Msg, ToDo, WhatAndWhere)
            Else
                ' no attachments, send stock reply
                Call SendMsg(Msg, strNoAttach, , ToDo)
                GoTo ExitProc
            End If

    End Select
End If

ExitProc:
Set fso = Nothing
Set MsgReply = Nothing
Set MsgAttach = Nothing
Set Msg = Nothing

End Sub

Option Explicit

Sub FileServ(Msg As Outlook.MailItem, sType As String, Optional sFilePath As String)

' -----------------------------------------------------------------------------------
' File Server portion of the File Put/Get System Code
' by Jimmy Pena, 4-4-2008
' http://www.codeforexcelandoutlook.com
'
' This sub takes the already-validated user input, determines whether it is
' a 'GET' or a 'PUT' request, and calls the sending sub appropriately
' -----------------------------------------------------------------------------------
'
Dim MsgAttach As Outlook.Attachments
Dim MsgReply As Outlook.MailItem
Dim strRecd As String
Dim i As Long
Dim Att As String
Dim strErr As String

Const strErrStart As String = "The following files were not saved: "
Const strSent As String = "Attached is the file you requested."

strRecd = "The files you sent have been saved to the " & sFilePath & " folder."

Select Case sType
    Case "FILEGET", "fileget"
        Call SendMsg(Msg, strSent, sFilePath, sType)
    
    Case "FILEPUT", "fileput"
        Set MsgAttach = Msg.Attachments
            For i = 1 To MsgAttach.Attachments.Count
                Att = MsgAttach.item(i).DisplayName

' -----------------------------------------------------------------------------------
' If any of the files cannot be saved, build a string with the filenames and
' send a msg back to requestor with those filenames
' -----------------------------------------------------------------------------------
                On Error Resume Next
                MsgAttach.item(i).SaveAsFile sFilePath & Att
                If Err <> 0 Then
                    strErr = strErr & Att
                End If
                On Error GoTo 0
            Next i

        If strErr <> "" Then
            Call SendMsg(Msg, strErrStart & strErr, , sType)
            GoTo ExitProc
        End If
        
        Call SendMsg(Msg, strRecd, , sType)
End Select

ExitProc:
Set MsgAttach = Nothing
End Sub

Sub SendMsg(Msg As Outlook.MailItem, sMsg As String, Optional sFilePath As String, Optional sType As String)

' -----------------------------------------------------------------------------------
' This sub is responsible for sending all responses, whether it is:
' a) error msgs for malformed requests;
' b) ack email to original requestor of successful 'PUT' request
' c) ack email with attachments for successful 'GET' request
' This sub itself calls the logging routine that appends the request to a CSV file for later review
' -----------------------------------------------------------------------------------

Dim MsgReply As Outlook.MailItem
Dim MsgRecip As Outlook.Recipient
Dim arr() As String
Dim strRecips As String
Dim i As Long

Set MsgReply = Msg.Reply

With MsgReply
    '.To = Msg.SenderName
    .BodyFormat = olFormatPlain
    .Body = sMsg
    .Subject = "Your File Request"
    '.Recipients.ResolveAll
    
    ' ----------------------------------------------------------------
    ' If you regularly send emails 'on behalf of' another, and
    ' want to use this feature here, just un-comment the line
    ' below and edit "My Email Name" to reflect the person
    ' or email address you are sending on behalf of.
    ' ----------------------------------------------------------------
    
    ' .SentOnBehalfOfName = "My Email Name"
    
    If sFilePath <> "" Then
        .Attachments.Add sFilePath
    End If
    
    strRecips = MsgReply.Recipients.item(1)

    .Send
End With

' ------------------------------------------------------------------------------------
' Simply comment out the line below if you don't want the logging feature.
' You should also comment out or remove the LogInformation sub below
' ------------------------------------------------------------------------------------

LogInformation strRecips & "," & sType & "," & sFilePath & "," & _
    MsgReply.Attachments.Count & "," & Date, "C:\FileRequestLog.csv"

Set MsgReply = Nothing
Set MsgRecip = Nothing
End Sub

Private Sub LogInformation(LogMsg As String, LogFile As String)
' ---------------------------------------------------------------------------------------------
' Based on code from:
' http://www.exceltip.com/st/Log_files_using_VBA_in_Microsoft_Excel/467.html
'
' This sub logs the information passed in the first argument to the filename/path
' specified in the second argument. Powerful and highly effective way to keep a
' log of your macro's activity.
' ---------------------------------------------------------------------------------------------
Dim FileNum As Integer
FileNum = FreeFile
Open LogFile For Append As #FileNum
Print #FileNum, LogMsg
Close #FileNum
End Sub

Private Function IsStringFound(sMsg As String, StringToCheck As String) As Boolean
' --------------------------------------------------------------
' returns True if string #2 is found within string #1
' works great as a UDF, replacing those long formulas like these:
' http://support.microsoft.com/kb/213889
' =IsStringFound(B1,A1)
' --------------------------------------------------------------
If InStr(sMsg, StringToCheck) > 0 Then
    IsStringFound = True
Else
    IsStringFound = False
End If

End Function