w00000w
01-25-2013, 08:44 PM
Hi, :hi:
I'm new user here, :rotlaugh:
I found this forum when I was search for how to copy all emails and accounts to local folder automatically.
I'm new with outlook vba,
I found a topic with a vba code, I've tried the code, it's working but I need to modify settings:
This is the code:
Option Explicit
Sub SaveMainEmailFolderToHardDrive()
Dim i As Long
Dim j As Long
Dim n As Long
Dim z As Long 'New line of code
Dim iItem As Long 'New line added from other code
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho As String 'New line added from other code
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 iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As Folder 'Modifed code - was 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 'Tried to Delete Code:
FSO.CreateFolder (StrFolderPath) 'Tried to Delete Code:
End If 'Tried to Delete Code:
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
With Outlook.ActiveExplorer.Selection 'New code added
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime) 'Modified Code: replaced mItem with .Item(j)
StrSubject = mItem.Subject 'Modified Code: replaced mItem with .Item(j)
StrWho = mItem.SenderName 'New Code
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg" 'Modified Code
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3 'Modified Code: replaced mItem with .Item(j)
'mItem.Delete 'New Code
Next j
End With 'New code added in conjunction with With code above in j
'Removed Code: On Error GoTo 0
'Former location of Next i code
'Copied code from above with "z" for reference - want access to subfolders only
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
With Outlook.ActiveExplorer.Selection 'New code added
For z = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(z)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrWho = mItem.SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg" 'Modified Code
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
' mItem.Delete
Next z
'Removed Code: On Error GoTo 0
End With 'New code added in conjunction with With code above in n
Next i 'Code moved from above
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 = StrAMPM & "-" & 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
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)
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
Sub SaveAllEmails_ProcessAllSubFolders()
End Sub
could you please help me to change the code:
I really need to do these steps:
1- copy all messages with account name and folder name and message name from all my accounts to local hard drive automatically like the code, without prompt form to select accounts and without prompt form to browser and select folders.
2- copy all messages from all accounts without Repetition and without replace items.
3- Run this macro automatically when I open MS Outlook 2010.
4- after that when the macro done: I need to close Outlook 2010 automatically.
just this :)
I appreciate your attention,
Thank you all.
I'm new user here, :rotlaugh:
I found this forum when I was search for how to copy all emails and accounts to local folder automatically.
I'm new with outlook vba,
I found a topic with a vba code, I've tried the code, it's working but I need to modify settings:
This is the code:
Option Explicit
Sub SaveMainEmailFolderToHardDrive()
Dim i As Long
Dim j As Long
Dim n As Long
Dim z As Long 'New line of code
Dim iItem As Long 'New line added from other code
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrWho As String 'New line added from other code
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 iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As Folder 'Modifed code - was 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 'Tried to Delete Code:
FSO.CreateFolder (StrFolderPath) 'Tried to Delete Code:
End If 'Tried to Delete Code:
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
With Outlook.ActiveExplorer.Selection 'New code added
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime) 'Modified Code: replaced mItem with .Item(j)
StrSubject = mItem.Subject 'Modified Code: replaced mItem with .Item(j)
StrWho = mItem.SenderName 'New Code
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg" 'Modified Code
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3 'Modified Code: replaced mItem with .Item(j)
'mItem.Delete 'New Code
Next j
End With 'New code added in conjunction with With code above in j
'Removed Code: On Error GoTo 0
'Former location of Next i code
'Copied code from above with "z" for reference - want access to subfolders only
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
With Outlook.ActiveExplorer.Selection 'New code added
For z = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(z)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrWho = mItem.SenderName
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrWho & " - " & StrReceived & " - " & StrName & ".msg" 'Modified Code
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
' mItem.Delete
Next z
'Removed Code: On Error GoTo 0
End With 'New code added in conjunction with With code above in n
Next i 'Code moved from above
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 = StrAMPM & "-" & 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
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)
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
Sub SaveAllEmails_ProcessAllSubFolders()
End Sub
could you please help me to change the code:
I really need to do these steps:
1- copy all messages with account name and folder name and message name from all my accounts to local hard drive automatically like the code, without prompt form to select accounts and without prompt form to browser and select folders.
2- copy all messages from all accounts without Repetition and without replace items.
3- Run this macro automatically when I open MS Outlook 2010.
4- after that when the macro done: I need to close Outlook 2010 automatically.
just this :)
I appreciate your attention,
Thank you all.