Outlook File Request System
Outlook Automated File Request System Using VBA
Do you get a lot of requests for people to send you files?
I find this to be a chore, so I came up with some event code for others to request files from you without any hassle or intervention required on your part. This code was written for those in a business environment who keep files on a publicly accessible network share. Use it to allow people to trade files with you without you having to babysit your email.
The following VBA code can be used to treat Outlook like an automated file server.
Paste the following code into your ThisOutlookSession module.
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
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
And this code should be placed in a standard module (Insert » Module).
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
' -----------------------------------------------------------------------------------
' 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
I leave most of the explanation of how the code works as an exercise for you. 
But if you do have questions about how the code works, contact me.
