Filing email messages to hard drive

[asphyx]

I have searched the forum and found some great examples of what I want to do. I have borowed some vba from earlier threads by rrenis and spartacus132 (many many thanks guys) that suit me almost perfectly and made some minor modifications. I am a complete vba novice but can find my way around and make simple changes.

The only problem I have now is that sometimes the date and time is generated correctly, i.e
2007_02_04_-11-26-40 Wade, Tony - Xu, Rebecca - Easter.msg
but on the majority of emails it comes out as what appears to be complete gibberish, i.e
-200_03_-03-200_-030-03-2 Wade, Tony - Vink, Hayden J. - Mice.msg
and I have no idea why.

Can anyone please have a look at the code and tell me why this might be. As it works sometimes and not others I guess it must be something to do with the format of the original email?

Thanks in advance for your help.


Option Explicit

Sub SaveSelectedEmails_RECEIVED()
Dim i As Long
Dim j As Long
Dim n As Long
Dim iItem As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrTo As String
Dim StrFrom As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Prompt As String
Dim Title As String
Dim mItem As MailItem
Dim FSO As Object
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If
On Error Resume Next
With Outlook.ActiveExplorer.Selection
For iItem = 1 To .Count
StrReceived = ArrangedDate(.Item(iItem).ReceivedTime)
StrSubject = .Item(iItem).Subject
StrTo = .Item(iItem).ReceivedByName
StrFrom = .Item(iItem).SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSavePath & StrReceived & " " & StrTo & " - " & StrFrom & " - " & StrName & ".msg"
StrFile = Left(StrFile, 256)
.Item(iItem).SaveAs StrFile, 3
' .Item(iItem).Delete'
Next
End With
ExitSub:
End Sub

Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function


Function ArrangedDate(StrDateInput)
Dim StrFullDate As String
Dim StrFullTime As String
' Dim StrAMPM As String'
Dim StrTime As String
Dim StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate As String
Dim StrDateTime As String
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
If Not Left(StrDateInput, 2) = "10" And _
Not Left(StrDateInput, 2) = "11" And _
Not Left(StrDateInput, 2) = "12" Then
StrDateInput = "0" & StrDateInput
End If
StrFullDate = Left(StrDateInput, 10)
If Right(StrFullDate, 1) = " " Then
StrFullDate = Left(StrDateInput, 9)
End If
StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If
' StrAMPM = Right(StrFullTime, 2)'
StrTime = "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrYear & "_" & StrMonth & "_" & StrDay
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function

Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function

[Charlize]

Dim avDate() As String
Dim avTime() As String
Dim vDate As String
ReDim Preserve avDate(3)
ReDim Preserve avTime(2)
' myItem is the emailobject
avDate = Split(CStr(myItem.ReceivedTime), "/")
avTime = Split(CStr(myItem.ReceivedTime), " ")
' this is for belgian format date
' 3th item in array is year with time, so we need from 1 to 4
' 2nd item is month
' 1st item is day
vDate = Mid(avDate(2), 1, 4) & "-" & avDate(1) & "-" & avDate(0)
Charlize

[asphyx]

Many thanks for taking the time to look at this for me Charlize. As I said, I am a novice but will try and include this in my code.

Thanks for your help.

[Charlize]

Try this modified version of the function (take a backup of your version to a txt-file before replacing). Your computer's dateformat must be MM/dd/yyyy (month/day/year).


Function ArrangedDate(StrDateInput)
Dim StrFullDate As String
Dim StrFullTime As String
' Dim StrAMPM As String'
Dim StrTime As String
Dim StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate As String
Dim StrDateTime As String
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
' If Not Left(StrDateInput, 2) = "10" Or _
' Not Left(StrDateInput, 2) = "11" Or _
' Not Left(StrDateInput, 2) = "12" Then
' StrDateInput = "0" & StrDateInput
' End If
StrFullDate = Left(StrDateInput, 10)
' If Right(StrFullDate, 1) = " " Then
' StrFullDate = Left(StrDateInput, 9)
' End If
StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
' Are the following three lines necessary ???
If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If
' StrAMPM = Right(StrFullTime, 2)'
StrTime = "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrYear & "_" & StrMonth & "_" & StrDay
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function
Charlize

ps.: Please don't send a pm to me regarding coding problems. Try to formulate them in this forum so everyone could make modifications to the code to make it run a little better (Even I don't know everything). Thanks. Otherwise, I'll have to send you an invoice :2p: :2p: :2p: (by using a pm).

[Charlize]

A modified version of the function using the code snippet I gave in an earlier post. The debug.print statements can be removed once you know which arrayitem holds the day, month, year and time values. You'll have to use F8 to run through your code to see the values. Be sure that you can see the direct window (that's where the debug.print statements are shown - ctrl + g in vbe editor).

Function ArrangedDate(StrDateInput)
Dim RegX As Object
Dim avDate() As String
Dim avTime() As String
Dim vDate As String
Dim StrDateTime As String
Set RegX = CreateObject("vbscript.regexp")
ReDim Preserve avDate(3)
ReDim Preserve avTime(2)
avDate = Split(StrDateInput, "/")
avTime = Split(StrDateInput, " ")
' Belgian way = day
Debug.Print avDate(0)
' month
Debug.Print avDate(1)
' year + time
Debug.Print avDate(2)
' date
Debug.Print avTime(0)
' time
Debug.Print avTime(1)
' Here you can build a check on the length of avdate(0)and avdate(1) _
if you really want to have two characters in the day and month
' if computersetting is d/M/yyyy (M/d/yyyy)
StrDateTime = avDate(0) & "_" & avDate(1) & "_" & _
Left(avDate(2), 4) & "-" & avTime(1)
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function
Charlize

[asphyx]

Thanks again Charlize, I managed to get the date working correctly with your second set of code, although it is probably a bit rough around the edges! As I mentioned I am a complete novice at VBA and am struggling to find time to learn how to become even vaugely competent at it.

Now that I have got that sorted it would be great to be able to progress the code to the next level that would be really useful. My ultimate objective would be to expand the code so that the filing of emails is properly and usefully automated. What I would like to do is as follows:

- The user starts the macro and a dialogue box asks the user for a job number
- The user enters a job number and presses OK (the job number represents a job directory that has already been set up on the hard drive to receive filed e-mails, i.e. c:\Projects\60019855\Email\)
- The macro copies any previously selected email messages to the above directory in msg format with the file name as per what I was trying to achieve originally (i.e. sent(or recieved) date_who sent it_who received it_ subject.msg)
- A dialogue box asks the user if they want to print the email, if yes the email prints to the default printer and macro goes to step below, if no go straight to step below.
- A dialogue box asks the user if they want to move the email to a folder in the mailbox (not the hard drive, this lets me keep a copy handy until I'm ready to delete it), if yes the macro asks the user to choose a folder to move it to, user presses ok and the message is moved, end of macro; if no macro ends.

Because both received and sent emails need to be able to be filed the above process needs to happen;
a) manually when the user selects messages in the inbox to be filed, and/or
b) after the user presses send on a message so that it can be filed straight away.

To me this is an insurmountable challenge but it doesn't seem all that complex for someone who knows what they are doing (or am I wrong?). I realise that it is a huge request to ask of strangers in a forum to even look at but I am really stuck.

Any help, thoughts or suggestions would be greatly appreciated.

Attached is the latest code.



Option Explicit

Sub SaveSelectedEmails_RECEIVED()
Dim i As Long
Dim j As Long
Dim n As Long
Dim iItem As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrTo As String
Dim StrFrom As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Prompt As String
Dim Title As String
Dim mItem As MailItem
Dim FSO As Object
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If
On Error Resume Next
With Outlook.ActiveExplorer.Selection
For iItem = 1 To .Count
StrReceived = ArrangedDate(.Item(iItem).ReceivedTime)
StrSubject = .Item(iItem).Subject
StrTo = .Item(iItem).ReceivedByName
StrFrom = .Item(iItem).SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSavePath & StrReceived & " _ " & StrTo & " _ " & StrFrom & " _ " & StrName & ".msg"
StrFile = Left(StrFile, 256)
.Item(iItem).SaveAs StrFile, 3
' .Item(iItem).Delete'
Next
End With
ExitSub:
End Sub

Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function

Function ArrangedDate(StrDateInput)
Dim StrFullDate As String
Dim StrFullTime As String
' Dim StrAMPM As String'
Dim StrTime As String
Dim StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate As String
Dim StrDateTime As String
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
' If Not Left(StrDateInput, 2) = "10" Or _ 'Not Left(StrDateInput, 2) = "11" Or _
' Not Left(StrDateInput, 2) = "12" Then ' StrDateInput = "0" & StrDateInput
' End If '
StrFullDate = Left(StrDateInput, 10)
' If Right(StrFullDate, 1) = " " Then
' StrFullDate = Left(StrDateInput, 9)
' End If
StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
' Are the following three lines necessary ???
' If Len(StrFullTime) = 10 Then
' StrFullTime = "0" & StrFullTime
' End If
' StrAMPM = Right(StrFullTime, 2)'
StrTime = "" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrYear & "-" & StrDay & "-" & StrMonth
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(StrDateTime, "")
ExitFunction:
Set RegX = Nothing
End Function

Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function

[Charlize]

Better use the function where I have incorporated the code snippet I gave you. Reason why is that the day, month, year and time are located in an item of the array avdate or avtime. The only thing we must be sure of is that the separator for the date is a /. If you are sure about how the date is formatted MM/d/yyyy or M/d/yyyy (and not d/M/yyyy) you can easily check if the length of the month and day is 1. If needed you can add a 0 to the item in the array.

Charlize