Custom Archive code -- modify my code!

  • Thread starter Thread starter Ray
  • Start date Start date
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
 
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
 
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)

-

"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
sjbtax Update Task Custom Field based upon Task Overdue Status Outlook VBA and Custom Forms 8
boblewis Technical Issue with Custom Form - Save to Drafts Not Syncing Outlook VBA and Custom Forms 1
G Apply Custom Contacts form to all existing Contacts Outlook VBA and Custom Forms 1
G Add Map It button to Custom Contacts Form in Outlook Outlook VBA and Custom Forms 1
G Outlook 2021 Add Picture to Custom Contact Form Outlook VBA and Custom Forms 2
X Custom icon (not from Office 365) for a macro in Outlook Outlook VBA and Custom Forms 1
P Can't add custom field to custom Outlook form, it always adds to the Folder instead Outlook VBA and Custom Forms 2
AndyZ Contact Custom Form Tiny Text Outlook VBA and Custom Forms 3
A How to reduce size of custom contact form? Outlook VBA and Custom Forms 3
S Custom Contact card - need help creating one Outlook VBA and Custom Forms 1
S Outlook 2019 Custom outlook Add-in using Visual Studio Outlook VBA and Custom Forms 0
S Adding Custom Forms Outlook VBA and Custom Forms 4
Witzker How to get the button Karte ( map) in custom contact form Outlook VBA and Custom Forms 2
B Outlook 2019 Custom Email form - Edit default email form Outlook VBA and Custom Forms 6
D Outlook 365 Custom forms field limit? Outlook VBA and Custom Forms 4
J PSA: How to create custom keyboard shortcut for "Paste Unformatted Text" in Outlook on Windows Outlook VBA and Custom Forms 1
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

Similar threads

Back
Top