Custom Archive code -- modify my code!

Status
Not open for further replies.
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
 
D

Dmitry Streblechenko

Why not save the messages in the MSG format (mailItem.SaveAs) instead of

just saving the attachments ?

Dmitry Streblechenko (MVP)

-

"Ray" <rschinzel@gmail.com> wrote in message

news:dc3f9933-772d-4cdc-ae66-9dea213060aa@o10g2000yqa.googlegroups.com...
> 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
 
R

Ray

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
 
D

Dmitry Streblechenko

Did you make sure the file extension was .MSG?

Dmitry Streblechenko (MVP)

-

"Ray" <rschinzel@gmail.com> wrote in message

news:de4c2a47-7d8e-4a02-90df-0c906d59e9cd@v30g2000yqm.googlegroups.com...
> 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

>
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
M copy field value to custom field Outlook VBA and Custom Forms 0
J Does the .fdm contain my custom form? How to make ol use it? - ol2007 Outlook VBA and Custom Forms 4
J ol2021 custom form not displaying pics Outlook VBA and Custom Forms 37
N "Perform a Custom Action" Outlook VBA and Custom Forms 0
cbufacchi Outlook 365 Populate custom Outlook Appoint form Outlook VBA and Custom Forms 2
C Create Meeting With Custom Form Outlook VBA and Custom Forms 2
FryW Need help modifying a VBA script for in coming emails to auto set custom reminder time Outlook VBA and Custom Forms 0
J custom form not displaying pictures Outlook VBA and Custom Forms 7
I Button PDF in Outlook Contact custom form Outlook VBA and Custom Forms 1
K Font Sizing in Custom Form Regions for Contacts Outlook VBA and Custom Forms 1
V Update new custom field Outlook VBA and Custom Forms 5
D Anyone tell me where custom view settings are stored? Outlook VBA and Custom Forms 9
S Outlook 2016 Arrange tasks by date, additional custom sorting, but still use friendly terms like Today, Tomorrow, This week? Using Outlook 1
K can't get custom form to update multiple contacts using VBA Outlook VBA and Custom Forms 3
H Custom Outlook Contact Form VBA Outlook VBA and Custom Forms 1
S Custom Field Cannot Be Displayed In Views Outlook VBA and Custom Forms 2
D Custom Search Folders not refreshing/updating automatically Using Outlook 0
F Validation on custom task form after task acceptance Outlook VBA and Custom Forms 1
K UDF with formula not showing on Calendar custom view. Outlook VBA and Custom Forms 0
S Create a clickable custom column field Outlook VBA and Custom Forms 0
I Error saving screenshots in a custom form in outlook 2016, outlook 365 - ok in outlook 2013, outlook 2010 Outlook VBA and Custom Forms 5
M VbScript for Command Button on Contacts Custom Form Using Outlook 1
G Other users can't see P.2 with custom fields in Form Outlook VBA and Custom Forms 0
O Create a custom contact form - questions before messing things up... Outlook VBA and Custom Forms 4
S Reference Custom Fields with VBA Outlook VBA and Custom Forms 2
L Custom Form Tutoral? Outlook VBA and Custom Forms 6
D Lost Access to Custom Form Outlook VBA and Custom Forms 4
M vCard does not have user-defined fields from my custom contact form (365) Using Outlook 1
S Outlook Custom Form Scripting only working when clicking on "Run this form" Outlook VBA and Custom Forms 2
A Custom VBA to sort emails into folders Outlook VBA and Custom Forms 0
Victor_50 Outlook 2013 Custom Contact Form starts with "E-mail 2" Outlook VBA and Custom Forms 2
C Custom Form (seperate layout pages and message reading pane) Outlook VBA and Custom Forms 0
C Reading Pane for Custom Form Outlook VBA and Custom Forms 2
M Custom Calendar Print Suggestions? Using Outlook 0
K Custom Category Colors Using Outlook 2
N Custom Form Controls Not Visible To Recipient Outlook VBA and Custom Forms 3
E To convert imported data to custom fields in Task list Outlook VBA and Custom Forms 1
Randy Redekopp How To Merge Contact Info to Email Custom Form Template Using Outlook 2
D Problem with custom form including _DocSiteControl1 Outlook VBA and Custom Forms 0
C Custom Outlook Form - Populate Information from Radio Button / Check Box Using Outlook 0
H Custom Signature Not Displayed When Account Selected Outlook VBA and Custom Forms 10
E Custom formula for columns Using Outlook 3
W Message class changes of a custom form changes to the default form Using Outlook 2
A Possible to hide ribbon with custom appointment form? Outlook VBA and Custom Forms 3
S Custom Form, copy user field data to message body Outlook VBA and Custom Forms 12
Andrew Quirl Custom form to route requests based on input criteria Outlook VBA and Custom Forms 1
D Using a VBA Custom Form to Send Reoccurring Email Upon Task Completion Outlook VBA and Custom Forms 4
W Setting up a custom form Outlook VBA and Custom Forms 2
A Greyed out checkbox in custom form Outlook VBA and Custom Forms 4
Z Outlook Custom Form: Adding Dropdown(Project Code) at the end of subject Outlook VBA and Custom Forms 0

Similar threads

Top