PDA

View Full Version : Solved: Save multiple emails with the same data used to create file name


g8r777
10-26-2011, 03:45 PM
I have the following code (which many people have posted) to save selected emails. My issue is that if multiple emails that are sent by the same person on the same day with the same subject, after the first email is saved the following email overwrites the first and then the next overwrites that one and so on.

Ultimately only one email gets saved and the others are lost (or in the Outlook deleted items).

Is there a way to have the code serially name the emails i.e. "if this file name already exists, save the next email as "File Name 2" then the next as "File Name 3" and so on?


Option Explicit
Sub SaveSelectedDelete()
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 StrWho 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
StrWho = .Item(iItem).SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSavePath & StrReceived & " - " & StrWho & " - " & StrName & ".msg"
StrFile = Left(StrFile, 256)
.Item(iItem).SaveAs StrFile, 3
.Item(iItem).Delete

Next
End With

ExitSub:

End Sub
Sub SaveSelectedNoDelete()
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 StrWho 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
StrWho = .Item(iItem).SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSavePath & StrReceived & " - " & StrWho & " - " & StrName & ".msg"
StrFile = Left(StrFile, 256)
.Item(iItem).SaveAs StrFile, 3

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 StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate 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

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
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(StrDate, "-")

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



Thank you,

Brian
monarchd
10-26-2011, 06:02 PM
How about using a date/time stamp in the file name:

StrSavePath & StrReceived & " - " & StrWho & " - " & StrName & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".msg"
g8r777
10-27-2011, 08:01 AM
I thought about that and it is a good suggestion that would work.

I would like to avoid that if possible and just go with the serial numbering.

Our company uses a file naming convention and adding the time stamp would get away from that convention. Also, with the date, sender and subject being used as the file name, the file name is already ridiculously long. By then adding a time stamp the file name length we will reach ludicrous level.
g8r777
10-27-2011, 09:23 AM
I've made some progress. I've managed to add code that checks if a file name already exists and if so to append a number to it (in the middle after the date) and then continue sequentially.

My problem now is that I cannot figure out the proper code to get this to happen for the selection of emails and then stop.

Sub TestNoDelete()
Dim i As Long
Dim j As Long
Dim n As Long
Dim k As Integer
Dim iItem As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho 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
StrWho = .Item(iItem).SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSavePath & StrReceived & " - " & StrWho & " - " & StrName & ".msg"
StrFile = Left(StrFile, 256)
k = 1
If FileOrDirExists(StrFile) Then
Do
k = k + 1
StrFile = StrSavePath & StrReceived & " - " & k & " - " & StrWho & " - " & StrName & ".msg"
.Item(iItem).SaveAs StrFile, 3
Loop Until iItem = .Count

Else

.Item(iItem).SaveAs StrFile, 3
End If

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 StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate 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

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
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(StrDate, "-")

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

Function FileOrDirExists(PathName As String) As Boolean

Dim iTemp As Integer

'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)

'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select

'Resume error checking
On Error GoTo 0
End Function


My problem is with this part of the code:

k = 1
If FileOrDirExists(StrFile) Then
Do
k = k + 1
StrFile = StrSavePath & StrReceived & " - " & k & " - " & StrWho & " - " & StrName & ".msg"
.Item(iItem).SaveAs StrFile, 3
Loop Until iItem = .Count

Else

.Item(iItem).SaveAs StrFile, 3
End If

I cannot figure out how to code the loop to end at the number of items selected. The way the code is written now, the code loops endlessly and I have to force Outlook to quit.

Any help is appreciated. I think I'm close though.

Thank you,

Brian
g8r777
10-27-2011, 12:58 PM
I believe I have figured it out. Here is the complete code which will serially number emails if the information used to create the file name is the same.
The code appends a number to the end.

The code should not overwrite previously saved emails. It should loop through and give you the next available number.

Option Explicit
Sub SaveSelectedNoDelete()
Dim i As Long
Dim j As Long
Dim n As Long
Dim k As Integer
Dim iItem As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho 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
StrWho = .Item(iItem).SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSavePath & StrReceived & " - " & StrWho & " - " & StrName & ".msg"
StrFile = Left(StrFile, 256)

If FileOrDirExists(StrFile) Then
Do Until FileOrDirExists(StrFile) = False
k = k + 1
StrFile = StrSavePath & StrReceived & " - " & StrWho & " - " & StrName & " - " & k & ".msg"
Loop

.Item(iItem).SaveAs StrFile, 3

Else
.Item(iItem).SaveAs StrFile, 3

End If
Next
End With

ExitSub:

End Sub

Sub SaveSelectedDelete()
Dim i As Long
Dim j As Long
Dim n As Long
Dim k As Integer
Dim iItem As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho 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
StrWho = .Item(iItem).SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSavePath & StrReceived & " - " & StrWho & " - " & StrName & ".msg"
StrFile = Left(StrFile, 256)

If FileOrDirExists(StrFile) Then
Do Until FileOrDirExists(StrFile) = False
k = k + 1
StrFile = StrSavePath & StrReceived & " - " & StrWho & " - " & StrName & " - " & k & ".msg"
Loop

.Item(iItem).SaveAs StrFile, 3
.Item(iItem).Delete

Else
.Item(iItem).SaveAs StrFile, 3
.Item(iItem).Delete

End If
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 StrYear As String
Dim StrMonthDay As String
Dim StrMonth As String
Dim StrDay As String
Dim StrDate 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

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
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(StrDate, "-")

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

Function FileOrDirExists(PathName As String) As Boolean

Dim iTemp As Integer

'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)

'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select

'Resume error checking
On Error GoTo 0
End Function