R
Ray
Hi -
For whatever reason, my company doesn't want us to save our emails and
has made backing them up as manual as possible. With ALOT of help
from Jimmy Pena at www.codeforexcelandoutlook.com (an excellent
site!), I've made a good start at creating a procedure to do this but
have hit a wall and need some help. The current version of the code
is below ... please note that I'm very new at Outlook VB so the
changes I made to Jimmy's original code are probably pretty ugly. All
input is welcome ...
I'm using OL-07 and Windows XP ... currently, the code does this:
1) loop through the highlighted (not open) message(s),
2) prompts user for back-up folder (code for this is below also)
3) saves attachments into the folder
That's where it ends ...
Other features I'd like to have include:
** save email (including recipients, dates, body, etc) as PDF (similar
to using PDF add-in)
** if NO attachments, save email only in the selected folder (with Msg-
Subject as filename)
** if ANY attachments, create folder with Msg-Subject as folder name,
then save email as PDF and all attachments
** delete the original email
I'm trying to learn the Outlook Object Model, so any help you can give
is GREATLY APPRECIATED ....
Thanks, Ray
Const PATH_SEPARATOR As String = "\"
Sub SaveEmailAndAttachments()
On Error GoTo ErrorHandler
Dim olApp As New Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToSave As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim msg As Selection
Dim atts As Outlook.Attachments
Dim att As Outlook.Attachment
Dim HDFolder As String
Dim i As Long, c As Long, z As Long
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim MyType As String
' Set olApp = GetOutlookApp
Set olNS = GetNamespace("MAPI")
Set myOlExp = olApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
c = myOlSel.Count
z = 1
For z = 1 To c
MyType = TypeName(myOlSel.Item(z))
' MsgBox MyType
If MyType <> "MailItem" Then GoTo ProgramExit
' get hard drive folder
HDFolder = BrowseForFolder
If Len(HDFolder) = 0 Then GoTo ProgramExit
HDFolder = HDFolder & PATH_SEPARATOR
' For Each msg In itms
Set atts = myOlSel.Item(z).Attachments
' loop through attachments, save to HD and delete
' must loop backwards when deleting
If atts.Count = 1 Then
atts.Item(1).SaveAsFile HDFolder & atts.Item(1).DisplayName
Else
For i = atts.Count To 1 Step -1
atts.Item(i).SaveAsFile HDFolder & atts.Item(i).DisplayName
atts.Item(i).Delete
Next i
End If
' Type can be: olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT,
olVCal, olVCard, olICal, or olMSGUnicode
' this will trigger Outlook object model guard
myOlSel.Item(z).SaveAs HDFolder & Format(myOlSel.Item
(z).ReceivedTime, "mmddyy hhmmss") _
& " " & myOlSel.Item(z).Subject, olMSG
Next z
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
' from http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0,
OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
For whatever reason, my company doesn't want us to save our emails and
has made backing them up as manual as possible. With ALOT of help
from Jimmy Pena at www.codeforexcelandoutlook.com (an excellent
site!), I've made a good start at creating a procedure to do this but
have hit a wall and need some help. The current version of the code
is below ... please note that I'm very new at Outlook VB so the
changes I made to Jimmy's original code are probably pretty ugly. All
input is welcome ...
I'm using OL-07 and Windows XP ... currently, the code does this:
1) loop through the highlighted (not open) message(s),
2) prompts user for back-up folder (code for this is below also)
3) saves attachments into the folder
That's where it ends ...
Other features I'd like to have include:
** save email (including recipients, dates, body, etc) as PDF (similar
to using PDF add-in)
** if NO attachments, save email only in the selected folder (with Msg-
Subject as filename)
** if ANY attachments, create folder with Msg-Subject as folder name,
then save email as PDF and all attachments
** delete the original email
I'm trying to learn the Outlook Object Model, so any help you can give
is GREATLY APPRECIATED ....
Thanks, Ray
Const PATH_SEPARATOR As String = "\"
Sub SaveEmailAndAttachments()
On Error GoTo ErrorHandler
Dim olApp As New Outlook.Application
Dim olNS As Outlook.NameSpace
Dim FolderToSave As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim msg As Selection
Dim atts As Outlook.Attachments
Dim att As Outlook.Attachment
Dim HDFolder As String
Dim i As Long, c As Long, z As Long
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim MyType As String
' Set olApp = GetOutlookApp
Set olNS = GetNamespace("MAPI")
Set myOlExp = olApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
c = myOlSel.Count
z = 1
For z = 1 To c
MyType = TypeName(myOlSel.Item(z))
' MsgBox MyType
If MyType <> "MailItem" Then GoTo ProgramExit
' get hard drive folder
HDFolder = BrowseForFolder
If Len(HDFolder) = 0 Then GoTo ProgramExit
HDFolder = HDFolder & PATH_SEPARATOR
' For Each msg In itms
Set atts = myOlSel.Item(z).Attachments
' loop through attachments, save to HD and delete
' must loop backwards when deleting
If atts.Count = 1 Then
atts.Item(1).SaveAsFile HDFolder & atts.Item(1).DisplayName
Else
For i = atts.Count To 1 Step -1
atts.Item(i).SaveAsFile HDFolder & atts.Item(i).DisplayName
atts.Item(i).Delete
Next i
End If
' Type can be: olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT,
olVCal, olVCard, olICal, or olMSGUnicode
' this will trigger Outlook object model guard
myOlSel.Item(z).SaveAs HDFolder & Format(myOlSel.Item
(z).ReceivedTime, "mmddyy hhmmss") _
& " " & myOlSel.Item(z).Subject, olMSG
Next z
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
' from http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0,
OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
