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

[gmayor]

The following will work, and includes code to create the named folder, to remove illegal filename characters and create missing folders. Change the default path and domain name as appropriate.

Option Explicit

Sub SaveMessage()
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
If Not TypeName(olMsg) = "MailItem" Then
MsgBox "Select a mail item!"
GoTo lbl_Exit
End If
SaveItem olMsg
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub

Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String
Dim fPath As String
fPath = "\\myserver\folder\"
fPath = InputBox("Enter the path to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message", fPath)
CreateFolders fPath

If olItem.Sender Like "*@gmayor.com" Then 'Your domain
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, fPath, fname
lbl_Exit:
Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

[carly]

[QUOTE=gmayor;340897]The following will work, and includes code to create the named folder, to remove illegal filename characters and create missing folders. Change the default path and domain name as appropriate.

Sorry, but I cannot get this to work, it doesn't seem to be finding the folder and I'm sure the path is correct in the code.

[gmayor]

I note that the default path is a UNC network file path. In which case you are correct, the version of CreateFolders I posted would not work with such a path. (I wrote it down and still missed it :omg2:) Replace the CreateFolders and FolderExists functions with the following. Note the Root network drive must exist.


Public Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

[carly]

[QUOTE=gmayor;341051]I note that the default path is a UNC network file path. In which case you are correct, the version of CreateFolders I posted would not work with such a path. (I wrote it down and still missed it :omg2:) Replace the CreateFolders and FolderExists functions with the following. Note the Root network drive must exist.

Thanks heaps. I've messed about with this for some time, but I'm a real newie. I'm coming up with 'ambiguous name detected: Createfolders'

Sorry to be a pain, but would you mind pasting the complete code together? Clearly I'm just not nailing it on my end! :)

[gmayor]

You appear to have added the second createfolders macro instead of replacing the original, hence the ambiguous name.

As long as the path you are saving to exists (here fPath = "\\myserver\folder\") , you can simplify the code to the following
Don't forget to put your own domain name in the line - If olItem.Sender Like "*@gmayor.com" Then 'Your domain:



Option Explicit

Sub SaveMessage()
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
If Not TypeName(olMsg) = "MailItem" Then
MsgBox "Select a mail item!"
GoTo lbl_Exit
End If
SaveItem olMsg
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub

Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String
Dim fPath As String
fPath = "\\myserver\folder\" 'The path where the messages are to be saved

If olItem.Sender Like "*@gmayor.com" Then 'Your domain
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, fPath, fname
lbl_Exit:
Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[carly]

That macro works great thanks very much. But rather than saving the messages to a root folder, we do want a popup so we can specify a folder within the default directory. Either create the folder if it's not there and save inside, or save it inside an already created folder. If the popup can just ask for a folder name (in our case a number like 78456) and create/save inside a folder of that name within our myserver\folder directory that would be awesome

[gmayor]

That is what we had initially, once you change the CreateFolders macro for the second version? However if you are going to enter a number as the folder, then use the following, but before running it, change the network root folder to what you have there in the line below. The numbered folder will be created as a sub folder of that folder. Ensure that you retain the final backslash character.

Const fRootPath As String = "\\myserver\rootfoldername\"
By including the prompt for the folder you cannot conveniently use the main code as a script with a rule to automatically process the messages as they arrive.

Option Explicit

Sub SaveMessage()
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
If Not TypeName(olMsg) = "MailItem" Then
MsgBox "Select a mail item!"
GoTo lbl_Exit
End If
SaveItem olMsg
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub

Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String
Dim fPath As String
Const fRootPath As String = "\\myserver\rootfoldername\"
fPath = InputBox("Enter the Folder Number in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath = Replace(fPath, "\", "")
fPath = fRootPath & fPath
CreateFolders fPath

If olItem.Sender Like "*@gmayor.com" Then 'Your domain
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, fPath, fname
lbl_Exit:
Exit Sub
End Sub

Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[nathandavies]

Hi GMayor,

I have been reading this post and found it very interesting as i'm trying to complete something very similar, but my folder structure is a bit different at the minute I have to find the folder location (\\server name\Projects\drawings\*customer*\*project number & name*) and then in the project name i have another folder *correspondence* and then two folders *sent* or *received*.

Would it be possible to change the code so that the text box appears twice so that i can put in the customer and the project name and number(example of project title: P1711 - Project Name), and then it saves the email in the correct folder either *sent* or *received* based on the email address and also creating a new folder with the date and time every time you save an email?

[gmayor]

The following changes to the macro named below should work


Sub SaveItem(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 04/03/2017
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Const fRootPath As String = "\\server name\Projects\drawings\" 'Change the 'server name' as appropriate
fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")
fPath2 = InputBox("Enter the project name and number.", _
"Save Message")
fPath2 = Replace(fPath2, "\", "")

strPath = fRootPath & fPath1 & "\" & fPath2
CreateFolders strPath
CreateFolders strPath & "\Sent"
CreateFolders strPath & "\Received"

If olItem.sender Like "*@gmayor.com" Then 'Your domain
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "\Sent\" & fname
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "\Received\" & fname
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strPath, fname
lbl_Exit:
Exit Sub
End Sub

[nathandavies]

Thanks Graham, that works exactly as it should. would it be possible to change it so that you dont have to put the full folder name in the second input box? i would like to only put project number X1234 its the same format for all folders 5 digital reference first.

also i have a folder within the main folder which is "correspondonce" would it be possible to created the "Sent" & "Received" folders in that folder?

[nathandavies]

Graham, I have managed to change the code to save in the correspondence folder, its just the 5 character input i need to change.


Option ExplicitSub SaveMessage()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
If Not TypeName(olMsg) = "MailItem" Then
MsgBox "Select a mail item!"
GoTo lbl_Exit
End If
SaveItem olMsg
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub

Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Const fRootPath As String = "\\NEWBENSON\Projects\drawings\"
fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")
fPath2 = InputBox("Enter the project name and number.", _
"Save Message")
fPath2 = Replace(fPath2, "\", "")

strPath = fRootPath & fPath1 & "\" & fPath2
CreateFolders strPath
CreateFolders strPath & "Correspondence" & "\Sent"
CreateFolders strPath & "Correspondence" & "\Received"

If olItem.Sender Like "*@email.co.uk" Then
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Sent\" & fname
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Received\" & fname
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strPath, fname
lbl_Exit:
Exit Sub
End Sub

Private Sub CreateFolders(strPath As String)
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Sub CopyToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String

Dim objFolder As Outlook.MAPIFolder
Dim strColA, strColB, strColC, strColD, strColE, strColF As String

' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Book1.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error Resume Next
' Open the workbook to input the data
' Create workbook if doesn't exist
Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
Set xlWB = xlApp.Workbooks.Add
xlWB.SaveAs FileName:=strPath
End If
On Error GoTo 0
Set xlSheet = xlWB.Sheets("Sheet1")

On Error Resume Next
' add the headers if not present
If xlSheet.Range("A2") = "" Then
xlSheet.Range("A2") = "Sender Name"
xlSheet.Range("B2") = "Sent To"
xlSheet.Range("C2") = "Subject"
xlSheet.Range("D2") = "Body"
xlSheet.Range("E2") = "Date"
End If

'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

'collect the fields

strColA = olItem.SenderName
strColB = olItem.To
strColC = olItem.Subject
strColD = olItem.Body
strColE = olItem.ReceivedTime



' Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColC)


If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
End Select
End If
' End Exchange section


'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("c" & rCount) = strColC
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE

'Next row
rCount = rCount + 1
xlWB.Save
' don't wrap lines
xlSheet.Rows.WrapText = True
xlWB.Save
xlWB.Close 1

If bXStarted Then
'xlApp.Quit 'With looped messages it will be faster if Excel is not closed
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub

[nathandavies]

Hi Graham,

I have been testing the code today and have noticed it is not saving my "SENT" emails in the correct folder it keeps saving them in the "RECEIVED" folder. I have tried changing
If olItem.Sender Like "*@email.co.uk" Then to different emails or usernames but it still doesn't work. Any ideas as to why?


Also would it be possible to change this bit of code so that i only have to input 5 digits (X1234)


fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")
fPath2 = InputBox("Enter the project name and number.", _
"Save Message")
fPath2 = Replace(fPath2, "\", "")

[gmayor]

Is 'email.co.uk' the demain name associated with your e-mail account? The line is checking for messages sent by you.
I don't understand the second part of your question. Can you clarify.

[nathandavies]

I have changed it to out domain in my copy, @dbensoncontrols.co.uk but that still doesn't seem to work.

Our folder structure is like this "\\Servername\Projects\Drawings\customer\P1234 Liverpool Street Station"

I would like to just search for the *P1234* in the folder not the full name - *P1234 liverpool street station* all projects start with the a letter followed by 4 digits.

Hope this helps

[gmayor]

Did you include the asterisk?
*@dbensoncontrols.co.uk

The following function in the same module will give you the folder path (if it exists) from the five input characters
thus
fPath = GetPath


Private Function GetPath() As String
Const strRoot As String = "\\Servername\Private\Projects\Drawings\customer\"
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter the 5 character project number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot)
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder) & Chr(92)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

[nathandavies]

Yes, i have included the * still doesn't seem to work.

Could you please show me where to include the extra line.


Private Function GetPath() As String Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot)
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder) & Chr(92)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function
Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Const fRootPath As String = "\\NEWBENSON\Projects\drawings\"

fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")

fPath2 = InputBox("Enter the project name and number.", _
"Save Message")
fPath2 = Replace(fPath2, "\", "")

strPath = fRootPath & fPath1 & "\" & fPath2
CreateFolders strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"

If olItem.Sender Like "*@dbensoncontrols.co.uk" Then 'Looks for messages from you
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Sent\" & fname
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Received\" & fname
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strPath, fname
CopyToExcel olItem, strPath 'The line goes here
lbl_Exit:
Exit Sub

End Sub

[nathandavies]

Graham, i have fixed the issue with the sent folder, you have to put in your user name exactly and then it works.

If you would be able to help me with the Get Path Modification so i only have to put the customer name then the 5 characters that would be great!

[gmayor]

Are you saying that in the line
Const strRoot As String = "\\Servername\Private\Projects\Drawings\customer\"
customer is the name of the customer?

Actually Private\ is from my network path and shouldn't be in the string, which explains why the function doesn't work :(.

Your last version shows the root as "\\NEWBENSON\Projects\drawings\" There is no reference to 'customer'

In your message you indicated Our folder structure is like this "\\Servername\Projects\Drawings\customer\P1234 Liverpool Street Station"
thus

\\NEWBENSON\Projects\drawings\customer name\P1234 Liverpool Street Station"
and that you want to add the folders
\\NEWBENSON\Projects\drawings\customer name\Correspondence\Sent"
and
\\NEWBENSON\Projects\drawings\customer name\Correspondence\Received"

In that case what's the relevance of the P1234? Is P1234 a unique ID that will identify the 'customer name' from minimal input? That is certainly possible with a modification to the GetPath.

Where is the workbook location relative to the path? Is it in the folder
\\NEWBENSON\Projects\drawings\customer name\
and it is that folder you now wish to locate or do you just want to identify the customer name (or both)?

[nathandavies]

Graham, we have an input box for the customer name already so that bit works fine. the project file "P1234 Liverpool Street Starion" is where I want to cut down the characters to look at just P1234 this is the unique I'd I want to use to find the folder.. This is fpath2 in the code

[gmayor]

I don't know if it is my cognitive process or your explanations, but the more you explain the more confusing your requirement becomes.
I don't know if you want the project name that contains the five digit code e.g. 'P1234' or whether you want the full path. The following will provide both.
strPath is the path to the customer - "\\NEWBENSON\Projects\drawings\Customer" - No end slash
fPath1 is the path of the project - "\\NEWBENSON\Projects\drawings\Customer\P1234 Liverpool Street Station\"
strProject is the project - "P1234 Liverpool Street Station"
I still don't know where you want the Correspondence folders - in the customer folder or the project folder - and I don't know what you want for the Excel part you highlighted, but all the options you have raised are available by using the appropriate variables.


Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"

Private Function GetPath(strRootPath As String) As String
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRootPath)
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder) & Chr(92)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Dim vProject As Variant
Dim strProject As String

fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
If fPath1 = "" Then
MsgBox "User cancelled"
GoTo lbl_Exit
End If
strPath = strRoot & fPath1
Debug.Print strPath
CreateFolders strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"

fPath2 = GetPath(strRoot & fPath1)
If fPath2 = "" Then
MsgBox "The ID entered does not exist"
GoTo lbl_Exit
End If
Debug.Print fPath2
vProject = Split(fPath2, Chr(92))
strProject = vProject(UBound(vProject) - 1)
Debug.Print strProject

'End 'Remove this line after testing the paths

If olItem.sender Like "*@dbensoncontrols.co.uk" Then 'Looks for messages from you
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Sent\" & fname
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Received\" & fname
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strPath, fname
'CopyToExcel olItem, strPath 'The line goes here
lbl_Exit:
Exit Sub
End Sub

[nathandavies]

Hi Graham, I'm wanting the correspondence folders in the project folder, which is how my code is working now. Everything with excel is working great. the customer name is working correctly as well this is searching for the correct folder. the only change is that i only want to search for the project folder based on the first 5 characters of the folder. IE "P1234" and not have to input the full folder name IE "P1234 Liverpool Street Station"

I have just tried your code above and this doesn't seem to be saving the email anywhere.


Option ExplicitPrivate Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Sub SaveMessage()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
If Not TypeName(olMsg) = "MailItem" Then
MsgBox "Select a mail item!"
GoTo lbl_Exit
End If
SaveItem olMsg
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub


Private Function GetPath(strRootPath As String) As String
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRootPath)
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder) & Chr(92)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function
Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Dim vProject As Variant
Dim strProject As String
Dim objItem As Outlook.MailItem

fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
If fPath1 = "" Then
MsgBox "User cancelled"
GoTo lbl_Exit
End If
strPath = strRoot & fPath1
Debug.Print strPath
CreateFolders strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"

fPath2 = GetPath(strRoot & fPath1)
If fPath2 = "" Then
MsgBox "The ID entered does not exist"
GoTo lbl_Exit
End If
Debug.Print fPath2
vProject = Split(fPath2, Chr(92))
strProject = vProject(UBound(vProject) - 1)
Debug.Print strProject

'End 'Remove this line after testing the paths

If olItem.Sender Like "Nathan Davies" Then 'Looks for messages from you
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Sent\" & fname
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Received\" & fname
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strPath, fname
CopyToExcel olItem, strPath
lbl_Exit:

If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
objItem.Delete
End If


End Sub

[nathandavies]

Graham,

i have added a comment to the code so you can see exactly what i want to change.

thanks in advance.


Private Function GetPath() As String Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot)
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder) & Chr(92)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function


Exit Sub
Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Const fRootPath As String = "\\NEWBENSON\Projects\drawings\"
Dim objItem As Outlook.MailItem

fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")

fPath2 = InputBox("Enter the project name and number.", "Save Message") 'THIS IS THE PART I WANT TO CHANGE TO LOOK FOR eg "P1234" WHICH IS THE GETPATH FUNCTION I BELIVE.
fPath2 = Replace(fPath2, "\", "")

strPath = fRootPath & fPath1 & "\" & fPath2
CreateFolders strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"

If olItem.Sender Like "Nathan Davies" Then
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Sent\" & fname
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Received\" & fname
End If
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strPath, fname
CopyToExcel olItem, strPath 'The line goes here
lbl_Exit:

If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
objItem.Delete
End If


End Sub

[gmayor]

I have already given you the GetPath function that does that. Call it from your code. I have not included below the other functions, that appear elsewhere in the thread, and which are called by this macro. They go below this code. i.e. Option Explicit is the first line of the module.

I have annotated the code where it might be helpful.


Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"

Private Function GetPath() As String

Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot)
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim objItem As Outlook.MailItem
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")

fPath2 = GetPath
If fPath2 = "" Then
MsgBox "The project number does not exist!"
'so end processing
GoTo lbl_Exit
End If

'fPath2 = Replace(fPath2, "\", "") 'superfluous as there is no backslash character in fpath2

strPath = strRoot & fPath1 & "\" & fPath2
'CreateFolders strPath 'superfluous as the following line will create strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"

If olItem.sender Like "Nathan Davies" Then
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Sent\" & fname
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fname = "Correspondence\Received\" & fname
End If
'Remove illegal filename characters that might appear in the subject
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strPath, fname
'The CopyToExcel function earlier in the thread had only one named parameter
CopyToExcel olItem
If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
objItem.Delete
End If
lbl_Exit:
Exit Sub
End Sub

[nathandavies]

Hi Graham,

For some reason i keep getting a message box saying Folder Does Not Exist but in fact to does exist. I have re-arranged my code like you mentioned above, but not sure why this would not find the folder now.

Thanks in advance for your help!!

[gmayor]

Which folder does not exist?
What is the full path of the folder that 'does not exist'?

[nathandavies]

all the folders exist as i'm using live files for testing,

this is the full path.

\\servername\Projects\Drawings\customer\P1711 Liverpool Street Station

I typed in the customer name correctly and the P1711, but straight away it came up with the error folder does not exist.

[gmayor]

I hate to say it, but you are right :( The GetPath function took no account of the customer name and was based on an earlier path that had the customer in the root path. You pass the customer name to the GetPath sunction (strCustomer) and include it with the root path when starting the search.

The following however should work: Replace the GetPath function with this one, and change the start of the main macro as shown below it.


Private Function GetPath(strCustomer As String) As String

Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strroot & Chr(92) & strCustomer)
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim objItem As Outlook.MailItem
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")

fPath2 = GetPath(fPath1)
If fPath2 = "" Then
MsgBox "The project number does not exist!"
'so end processing
GoTo lbl_Exit
End If

strPath = fPath2

'CreateFolders strPath 'superfluous as the following line will create strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"
'Followed by the rest of the macro

[nathandavies]

I'm getting an error on the strRoot, not sure if it is because it is not defined so tried that and still did not work.


Private Function GetPath(strCustomer As String) As String
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

[nathandavies]

Graham, i have solved the above issue. but it still will not save the email for some reason. i have put my updated code in for your assistance.


Option ExplicitPrivate Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Private Function GetPath(strCustomer As String) As String
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer)
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim objItem As Outlook.MailItem
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")

fPath2 = GetPath(fPath1)
If fPath2 = "" Then
MsgBox "The project number does not exist!"
'so end processing
GoTo lbl_Exit
End If

strPath = fPath2

'CreateFolders strPath 'superfluous as the following line will create strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"
'Followed by the rest of the macro

[gmayor]

Regarding this and your other similar thread which relates to the attachments, The following is all the code required to achieve both aims in one operation. I have tested the code and it works here (albeit I have had to use a different network path). It certainly saves the messages (and their attachments separately) in the same folder..

I am beginning to wish I had never begun this :(


Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"

Sub TestCode()
Dim olMsg As MailItem
'On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveItem olMsg
lbl_Exit:
Exit Sub
End Sub

Private Function GetPath(strCustomer As String) As String
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim objItem As Outlook.MailItem
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String, strSavePath As String
fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")

fPath2 = GetPath(fPath1)
If fPath2 = "" Then
MsgBox "The project number does not exist!"
'so end processing
GoTo lbl_Exit
End If

strPath = fPath2
MsgBox strPath

'CreateFolders strPath 'superfluous as the following line will create strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"

'vProject = Split(fPath2, Chr(92))
'strProject = vProject(UBound(vProject) - 1)
'Debug.Print strProject

If olItem.sender Like "*@dbensoncontrols.co.uk" Then 'Looks for messages from you
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
strSavePath = strPath & "\Correspondence\Sent\"
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
strSavePath = strPath & "\Correspondence\Received\"
End If

fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strSavePath, fname
SaveAttachments olItem, strSavePath
'CopyToExcel olItem, strPath 'The line goes here
lbl_Exit:
Exit Sub
End Sub

Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
If Not olAttach.fileName Like "image*.*" Then
strFname = olAttach.fileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFolder, strFname, strExt)
olAttach.SaveAsFile strSaveFolder & strFname
'olAttach.Delete 'delete the attachment
End If
Next j
olItem.Save
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Public Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

[nathandavies]

Graham! That worked perfectly!! but is it possible to save the attachments in a different folder.

\Documents\Documents Received

I know you have done alot on this code already if its too much work then it is OK i understand!!

Thanks
ND

[gmayor]

You can save the attachments anywhere you like. The save function is called by the line

SaveAttachments olItem, strSavePath at the bottom of the SaveItem macro
and strSavePath is currently the folder where the message is saved.
strPath is the folder relating to the customer. If \Documents\Documents Received\ is a sub folder of that folder then you need to add a line to Create that folder immediately below the other CreateFolders lines in the SaveItem macro
e.g.
CreateFolders strPath & "\Documents\Documents Received"
and then use that folder in the line at the top of this reply e.g.

SaveAttachments olItem, strPath & "\Documents\Documents Received\"

[nathandavies]

Graham! you my friend are a genius!!

Everything is now working perfectly thank you so much for the codes!!

REP ADDED!

Cheers
ND

[Fredjo]

Hello Graham,

This is my very post here and I'd like to thank you already for your work into this discussion.
Code in post #8 here (can't post links), is really what I need.

My problem is that my file structure is like this :
0001 - Customer 1
0002 - Customer 2
0003 - Customer 3
...

Your code is doing well but I don't want to write the customer name each time.. I'd like to enter the customer number and that's all.
Can you help me with this ?

I'm willing to donate some for the help, can you provide me with a link ?
Thank you already,
Fred

[gmayor]

can you provide me with a link ?
FredContact me via my web site and explain what it is that you are trying to do and include the code that you are using.

[Fredjo]

Done. Thanks Graham.

[ksheck0810]

I came across this and was research a similar situation. However, as I tried to run the code, I noticed it is only saving one email at a time instead of an entire selection. Can you help with this where it will select multiple emails and save them to the designation folder? Also, how do you add a button that runs the macro automatically at the top of outlook? If you can help, I would greatly appreciate it.

[ksheck0810]

I came across this and was research a similar situation. However, as I tried to run the code, I noticed it is only saving one email at a time instead of an entire selection. Can you help with this where it will select multiple emails and save them to the designation folder? Also, how do you add a button that runs the macro automatically at the top of outlook? If you can help, I would greatly appreciate it.

[Big_online]

Thanks for help, this is very good,

Can you help me? can i change the code to save multiple selected emails to same folder?

Thanks

___________________________

Give me erro to post the code :(