Save Bulk Emails on HDD With IF/ELSEIF condition

[fax_squirl]

:hi: Good Day gents:hi: , can you please revise the following modified code (originally DRJ had the idea, i tried to mod it for own purpose), i really don't know what is wrong, i'm new to VB and all the help would be appreciated.

CODE:



Option Explicit

Sub SaveAllEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrFolderName As String
Dim StrSaveFolder As String
Dim StrSenderName As String
Dim StrTo As String

Dim Prompt As String
Dim Title As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection

Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If


Prompt = "Please enter the path to save all the emails to"
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))

For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFolderName = SubFolder.Name
StrFolderName = StripIllegalChar(StrFolderName)
StrSenderName = mItem.SenderName
StrSenderName = StripIllegalChar(StrSenderName)
StrTo = mItem.To
StrTo = StripIllegalChar(StrTo)
If LCase(StrFolderName) = "Inbox" Then
StrFile = StrSaveFolder & "e-to_" & StrSenderName & "_" & StrName & "_" & GetFormattedDate(StrReceived) & ".msg"
ElseIf LCase(StrFolderName) = "Sent Items" Then
StrFile = StrSaveFolder & "e-from_" & StrTo & "_" & StrName & "_" & GetFormattedDate(StrReceived) & ".msg"
End If

StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
Next j

Next i

ExitSub:

End Sub

Function GetFormattedDate(StrDate)
StrDay = DatePart("d", StrDate)
StrMonth = DatePart("m", StrDate)
StrYear = DatePart("yyyy", StrDate)
strHour = DatePart("h", StrDate)
strMinute = DatePart("n", StrDate)
If StrDay < 10 Then
StrDay = "0" & StrDay
End If
If StrMonth < 10 Then
StrMonth = "0" & StrMonth
End If
If strHour < 10 Then
strHour = "0" & strHour
End If
If strMinute < 10 Then
strMinute = "0" & strMinute
End If
GetFormattedDate = Left(StrYear, 2) & StrMonth & StrDay & "_" & strHour & strMinute
End Function



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, 6) & StrAMPM
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

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)

Dim SubFolder As MAPIFolder

Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder

ExitSub:

Set SubFolder = Nothing

End Sub


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)


BrowseForFolder = ShellApp.self.Path


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



I get the error

"Run-time error '-2147024809 (80070057)':
Could not complete the operation. One or more parameter values are not valid." :banghead:

and when i hit the debug it highlights the " mItem.SaveAs StrFile, 3" part of the code :banghead:


What the code does is try to bulk save emails either from the Inbox or Sent items with a predetermined name based on which section the email is located in. Any assistance will be met with merciless thank-yous.: pray2: :bow:

[mdmackillop]

You are forcing lower case comparison here, then using capitals in Inbox/Sent Items
If LCase(StrFolderName) = "Inbox" Then
StrFile = StrSaveFolder & "e-to_" & StrSenderName & "_" & StrName & "_" & GetFormattedDate(StrReceived) & ".msg"
ElseIf LCase(StrFolderName) = "Sent Items" Then
StrFile = StrSaveFolder & "e-from_" & StrTo & "_" & StrName & "_" & GetFormattedDate(StrReceived) & ".msg"
End If

StrDate value has a value of 2010202201_0270244 in my test, not recognisable as a date

[fax_squirl]

ok so i modified the script, runs like a dream but it doesn't recognize the subfolders from inbox and sent items. is there a possibility to add this into vb so it can recognize a subfolder from inbox and save the email one way and if the email resides in a subfolder from sent items save it another way? (automatically creating the subfolder as it saves)

for ex StrFile = StrSaveFolder & "e-to_" & StrTo & "_" & StrReceived & "_re_" & StrName & ".msg"

this worked for that but i didn't do an IF variable .

[mdmackillop]

Can you post your corrected code.

[fax_squirl]

here


Option Explicit

Sub SaveAllEmails_ProcessAllSubFolders()

Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrFolderName As String
Dim StrSaveFolder As String
Dim StrSenderName As String
Dim StrTo As String

Dim Prompt As String
Dim Title As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection

Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If


Prompt = "Please enter the path to save all the emails to"
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))

For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFolderName = SubFolder.Name
StrFolderName = StripIllegalChar(StrFolderName)
StrSenderName = mItem.SenderName
StrSenderName = StripIllegalChar(StrSenderName)
StrTo = mItem.To
StrTo = StripIllegalChar(StrTo)
If LCase(StrFolderName) = "inbox" Then
StrFile = StrSaveFolder & "e-from_" & StrSenderName & "_" & StrReceived & "_re_" & StrName & ".msg"
ElseIf LCase(StrFolderName) = "sent items" Then
StrFile = StrSaveFolder & "e-to_" & StrTo & "_" & StrReceived & "_re_" & StrName & ".msg"
End If

StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
Next j

Next i

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, 6) & StrAMPM
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

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)

Dim SubFolder As MAPIFolder

Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder

ExitSub:

Set SubFolder = Nothing

End Sub


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)


BrowseForFolder = ShellApp.self.Path


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