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

Why not save the messages in the MSG format (mailItem.SaveAs) instead of
just saving the attachments ?
--
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
-
"Ray" <(E-Mail Removed)> wrote in message
news:dc3f9933-772d-4cdc-ae66-(E-Mail Removed)...
> 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

Hi Dmitry -

My original code above attempts to use the 'olMSG' type to save the
email and it doesn't work ... I was able to get it work once, but when
I checked using Windows Explorer, it didn't seem to recognize the file-
type.

I'm certainly open to alternate solutions ...

thanks, ray

Did you make sure the file extension was .MSG?

--
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
-
"Ray" <(E-Mail Removed)> wrote in message
news:de4c2a47-7d8e-4a02-90df-(E-Mail Removed)...
> Hi Dmitry -
>
> My original code above attempts to use the 'olMSG' type to save the
> email and it doesn't work ... I was able to get it work once, but when
> I checked using Windows Explorer, it didn't seem to recognize the file-
> type.
>
> I'm certainly open to alternate solutions ...
>
> thanks, ray
>
>