Link to home
Start Free TrialLog in
Avatar of NobbyGee
NobbyGee

asked on

Copying Outlook Mail Items to a folder on C Drive using Macros

Hi there need of some quick assistance.  I need to copy an item in my inbox to a file on my C drive to allow me to image the file.  I want to do this with Macros.  i am very new to this and i have written what i think it should be but it does not seem to work.  Here is the code i have written:

Sub Save()
Dim theSel As Outlook.Selection
   
                Set theSel = Application.ActiveExplorer.Selection
     If theSel.Count = 0 Then
         Exit Sub
     Else
         For Each itm In theSel
            Set myitm = item.Items

       
           
               
                    itm.MailItem.SaveAsFile "C:\Dim\" & att.DisplayName
                         
               
               'itm.Close
         Next
         Set item = Nothing
         Set theSel = Nothing
     End If
    End Sub

Unfortunatly it does not seem to work.  Can anyone help from where i am going wrong.

Can anyone please help as this is getting urgent now!!

Matt
ASKER CERTIFIED SOLUTION
Avatar of David Lee
David Lee
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of NobbyGee
NobbyGee

ASKER

I took out the Ol before HTML and it worked fine i take it the first time after logging on the message that a program is trying to access data will appear as it seems to disappear when i try again
olHTML is the name of a constant so you shouldn't change it.  Yes, Outlook's built-in security will pop up the message about a program accessing data each time the macro runs.  There's no way around that.
Checking again only certain emails are actually working and i get a debug message regarding a problem with a certain message and it points to itm.saveas strFilename, olHTML.
Is that to do with the manner they have their outlook set up.
It looks as though the emails that have previously been forwarded (fw) or Replyed to (RE) seem to have a problem as they drop them in but i can not open them up in C.
Replace this line of code

    strFilename = "C:\Dim\" & itm.Subject & ".txt"

with

    strFilename = "C:\Dim\" & Replace(itm.Subject, ":", " ") & ".txt"

The problem is the colon that appears after RE or FWD.  Colons aren't allowed in a file name.  The revised command strips them out.
That works fine, if the email has been sent in a format other than Html i take it it will not work?
The format of the message shouldn't matter.  The script simply says to save it in HTML format, although it doesn't look to me like it's doing that.  I had originally tried the setting olText but Outlook kept saying I was using an invalid parameter, so I switched olHTML which it didn't complain about.  The SaveAs command is functionally the same as clicking File->Save As.  If you do that, then you'll see there's an option at the bottom fo the dialog-box titles "Save as type".  Choosing olHTML in code is the same as choosing HTML from the dialog-box.  
It is just a message that a message that came in Rich Text will not save and brings up the error discussed previously.  Hopefully we will not have many come in like that.

Well, apparently the body type does make a difference, although I can't understand why.  That aside, I added code to handle the differences and then tested on each possible type.  Replace what I sent earlier with this.

Sub SaveFile()
    Dim theSel As Outlook.Selection, _
        itm As MailItem, _
        itmAttachment As Attachment, _
        strFilename As String
    Set theSel = Application.ActiveExplorer.Selection
    If theSel.Count = 0 Then
        Exit Sub
    Else
        For Each itm In theSel
            strFilename = "C:\Dim\" & Replace(itm.Subject, ":", " ") & ".txt"
            itm.SaveAs strFilename, DetermineBodyFormat(itm.BodyFormat)
            If itm.Attachments.Count > 0 Then
                For Each itmAttachment In itm.Attachments
                    itmAttachment.SaveAsFile "C:\Dim\" & itmAttachment.FileName
                Next
            End If
        Next
        Set Item = Nothing
        Set theSel = Nothing
    End If
End Sub

Function DetermineBodyFormat(varFormat) As Integer
    Select Case intFormat
        Case olFormatRichText
            DetermineBodyFormat = olRTF
        Case olFormatHTML
            DetermineBodyFormat = olHTML
        Case olFormatPlain
            DetermineBodyFormat = olText
    End Select
End Function
I think it might be just one individual that it does not seem to work with
Hello,

That has been working great, thanks for all your help.  I have thought of something else now is it possible that when we save the file to C Dim that it copies the whole email over with the attachments.  I have tried to make changes by changing the txt to msg (see below)

 strFilename = "C:\Dim\" & Replace(itm.Subject, ":", " ") & ".msg"

But it states i do not have permissions to view it in that format.

Hope you can help

Matt
Hi, Matt.

I'm sorry but I'm not clear on what you're asking when you say, "... is it possible that when we save the file to C Dim that it copies the whole email over with the attachments".  The code already saves the message with the attachments.  Are you saying you want to save the entire message, not just the body?  If so, then changing the file extension from txt to msg won't do that.  I'd need to modify the code to issue a SaveAs command.  That's easily done but brings up a problem.  Any commands issued in code that access an address field, which SaveAs does, will trigger Outlook's built-in security.  This will generate a pop up dialog box saying that a program is accessing your email and asking for your permission to allow it to continue.  That means the save will no longer be automatic but will require manual action to save each item.  As an alternative, we could modify the code to save everything except the address fields.

Let me know how you want to proceed.
What we are doing is that we are document imaging particular files and saving them into our C DIM folder.  The info you gave previously was excellent as it takes the body of the email (Who it is from etc ) and the relevant attachments and places them separatly into the c dim folder.  What i was hoping is it possible that we could save the main email and the attachements as we see it as it comes in through Outlook - My idea of saving at as an MSG as they click on the message and then get to the attachements that way.  
As it would allow them not to have to route around to find which body of the email (currently the txt part) is linked to an attachment as there may be a number in there.

Matt
Ok, now I understand.  Yes, we can use SaveAs to save the entire message.  That will trigger the Outlook security issue I described and the message will be save in Outlook message format, so it won't be readable by anything but Outlook.  As an alternative we could modify the code to create a subfolder for each message and store the message and attachments in the subfolder.  We could even add code to create a link in the message file to each of the attachments.  In my opinion that'd be a better alternative.  It's your choice though.  How do you want to proceed?
The first option may be better as we after we drop it in C we take it and document in our iseries. Though the link in the message file would be good as they then would know which came with which and it will be easy to access the attachment.
Ok, replace the previous code with the code below.  While you are in the VB Editor you need to add a reference (Tools->References) to Windows Script Host Object Model.  This new version will make a folder under C:\Dim for each selected message and save the message and its attachments into that folder.  If a folder with the same name already exists, then it creates another folder and appends the current date and time to the folder name.  If there are attachments, then as it saves them it writes them into a list at the bottom of the message they were attached to.  I had originally said a link but we're writing these out as text files and they don't support links.  So it's just a list.  That still makes it more convenient for the reader.

Let me know if there are any problems.



Sub CreateNewMessage()
    Dim olMessage As MailItem, _
        objFSO As New FileSystemObject, _
        objFile As TextStream, _
        strBuffer As String
    Set objFile = objFSO.OpenTextFile("C:\Testing\Stationery1.htm")
    strBuffer = objFile.ReadAll
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
    Set olMessage = Application.CreateItem(olMailItem)
    olMessage.BodyFormat = olFormatHTML
    olMessage.HTMLBody = strBuffer
    olMessage.Display
End Sub

Sub SaveFile()
    Dim theSel As Outlook.Selection, _
        itm As MailItem, _
        itmAttachment As Attachment, _
        strFilename As String, _
        strPath As String, _
        strAttachFile As String, _
        objFSO As New FileSystemObject, _
        objMsgFile As TextStream
    Set theSel = Application.ActiveExplorer.Selection
    If theSel.Count = 0 Then
        Exit Sub
    Else
        For Each itm In theSel
            strPath = Replace(itm.Subject, ":", "")
            strPath = Replace(strPath, "\", "")
            strPath = "C:\Dim\" & strPath
            If objFSO.FolderExists(strPath) Then
                strPath = strPath & "(" & Date & "@" & Time & ")"
            End If
            objFSO.CreateFolder strPath
            strFilename = strPath & "\" & Replace(itm.Subject, ":", " ") & ".txt"
            itm.SaveAs strFilename, DetermineBodyFormat(itm.BodyFormat)
            If itm.Attachments.Count > 0 Then
                Set objMsgFile = objFSO.OpenTextFile(strFilename, ForAppending)
                objMsgFile.WriteLine "Attachments"
                For Each itmAttachment In itm.Attachments
                    strAttachFile = strPath & "\" & itmAttachment.FileName
                    itmAttachment.SaveAsFile strAttachFile
                    objMsgFile.WriteLine itmAttachment.Index & ". " & strAttachFile
                Next
                objMsgFile.Close
            End If
        Next
        Set Item = Nothing
        Set theSel = Nothing
        Set objMsgFile = Nothing
        Set objFSO = Nothing
    End If
End Sub

Function DetermineBodyFormat(varFormat) As Integer
    Select Case intFormat
        Case olFormatRichText
            DetermineBodyFormat = olRTF
        Case olFormatHTML
            DetermineBodyFormat = olHTML
        Case olFormatPlain
            DetermineBodyFormat = olText
    End Select
End Function


I have set up a new macro but kept the others and it keeps falling down on the Sub SAVEFILE() - It states AMBIGUOUS NAME DETECTED
Each macro is really a subroutine.  So there can only be one block of code that begins with

    Sub SaveFile()

You'll have to change the name of one of them.

Oops, I see I also  copied a macro that isn't a part of this.  Delete the macro called CreateNewMessage.
That works but really not what we are looking for, so going back to the original there is no way we can save as a .msg within C and when we click on it, it looks exactly like what you get when you click into an email through outlook With the body and attachments?
I think i have cracked it..

Sub SaveFile()
    Dim theSel As Outlook.Selection, _
        itm As MailItem, _
        itmAttachment As Attachment, _
        strFilename As String
    Set theSel = Application.ActiveExplorer.Selection
    If theSel.Count = 0 Then
        Exit Sub
    Else
        For Each itm In theSel
            strFilename = "C:\Dim\" & Replace(itm.Subject, ":", " ") & ".msg"
            itm.saveas strFilename
          If itm.Attachments.Count > 0 Then
               
       
            End If

           
        Next
        Set Item = Nothing
        Set theSel = Nothing
    End If
End Sub
Great stuff nobbyGee.  Used your code and made a few amendments to enable the user to select a folder and make it handle calendar items in a mailbox (did this by changing the variable type if itm from mail "mailitem" to "Object".
Sub SaveFile()
    Dim mySubject As String
    Dim theSel As Outlook.Selection, _
        itm As Object, _
        itmAttachment As Attachment, _
        strFilename As String
    Set theSel = Application.ActiveExplorer.Selection
    If theSel.count = 0 Then
        Exit Sub
    Else
        For Each itm In theSel
            mySubject = Replace(itm.Subject, ":", " ") & ".msg"
            mySubject = Replace(mySubject, "/", "-") & ".msg"
            strFilename = Get_Filename(False, , , mySubject)
            If strFilename = "" Then GoTo TheEnd
            itm.SaveAs strFilename
            If itm.Attachments.count > 0 Then
                
        
            End If
 
           
        Next
TheEnd:
        Set Item = Nothing
        Set theSel = Nothing
    End If
End Sub
 
Type tagOPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    strFilter As String
    strCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    strFile As String
    nMaxFile As Long
    strFileTitle As String
    nMaxFileTitle As Long
    strInitialDir As String
    strTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    strDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
 
Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
    Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
 
Const ahtOFN_READONLY = &H1
Const ahtOFN_OVERWRITEPROMPT = &H2
Const ahtOFN_HIDEREADONLY = &H4
Const ahtOFN_NOCHANGEDIR = &H8
Const ahtOFN_SHOWHELP = &H10
Const ahtOFN_NOVALIDATE = &H100
Const ahtOFN_ALLOWMULTISELECT = &H200
Const ahtOFN_EXTENSIONDIFFERENT = &H400
Const ahtOFN_PATHMUSTEXIST = &H800
Const ahtOFN_FILEMUSTEXIST = &H1000
Const ahtOFN_CREATEPROMPT = &H2000
Const ahtOFN_SHAREAWARE = &H4000
Const ahtOFN_NOREADONLYRETURN = &H8000
Const ahtOFN_NOTESTFILECREATE = &H10000
Const ahtOFN_NONETWORKBUTTON = &H20000
Const ahtOFN_NOLONGNAMES = &H40000
Const ahtOFN_EXPLORER = &H80000
Const ahtOFN_NODEREFERENCELINKS = &H100000
Const ahtOFN_LONGNAMES = &H200000
 
'Launches the 'GetOpenFilename' or 'GetSaveAsFilename' dialog
'Arguments  : 'OpenDialog', a boolean determining the dialog type 'GetOpenFilename'(TRUE)
'               or 'GetSaveAsFilename'(FALSE)
'           : 'FileDescription', a string describing the 'FileType' argument
'               eg. "Excel Files"
'           : 'FileType', a string specifying file filtering criteria,
'               eg. "*.xls" for Excel files
 
Function Get_Filename(ByVal OpenDialog As Boolean, _
                        Optional ByVal FileDescription As String, _
                        Optional ByVal FileType As String, _
                        Optional ByVal FileName As String, _
                        Optional ByVal InitialDir As String)
 
Dim strFilter As String
Dim strSaveFileName As String
 
    If FileType = "" Then
        FileDescription = "All Files"
        FileType = "*.*"
    End If
 
    strFilter = ahtAddFilterItem(strFilter, FileDescription, FileType)
    On Error GoTo 0
    strSaveFileName = ahtCommonFileOpenSave( _
                                        OpenFile:=OpenDialog, _
                                        Filter:=strFilter, _
                                        FileName:=FileName, _
                                        InitialDir:=InitialDir, _
                        Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)
                    
    Get_Filename = strSaveFileName
    
End Function
 
Function ahtCommonFileOpenSave( _
            Optional ByRef Flags As Variant, _
            Optional ByVal InitialDir As Variant, _
            Optional ByVal Filter As Variant, _
            Optional ByVal FilterIndex As Variant, _
            Optional ByVal DefaultExt As Variant, _
            Optional ByVal FileName As Variant, _
            Optional ByVal DialogTitle As Variant, _
            Optional ByVal hwnd As Variant, _
            Optional ByVal OpenFile As Variant) As Variant
'The parameters are listed below are optional.
'
' In:
' Flags: one or more of the ahtOFN_* constants, OR'd together.
' InitialDir: the directory in which to first look
' Filter: a set of file filters, set up by calling
' AddFilterItem. See examples.
' FilterIndex: 1-based integer indicating which filter
' set to use, by default (1 if unspecified)
' DefaultExt: Extension to use if the user doesn't enter one.
' Only useful on file saves.
' FileName: Default value for the file name text box.
' DialogTitle: Title for the dialog.
' hWnd: parent window handle
' OpenFile: Boolean(True=Open File/False=Save As)
' Out:
' Return Value: Either Null or the selected filename
Dim OFN As tagOPENFILENAME
Dim strFilename As String
Dim strFileTitle As String
Dim fResult As Boolean
    ' Give the dialog a caption title.
    If IsMissing(InitialDir) Then InitialDir = CurDir
    If IsMissing(Filter) Then Filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(Flags) Then Flags = 0&
    If IsMissing(DefaultExt) Then DefaultExt = ""
    If IsMissing(FileName) Then FileName = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    If IsMissing(hwnd) Then hwnd = Get_OfficeCompHWND
    If IsMissing(OpenFile) Then OpenFile = True
    ' Allocate string space for the returned strings.
    strFilename = Left(FileName & String(256, 0), 256)
    strFileTitle = String(256, 0)
    ' Set up the data structure before you call the function
    With OFN
        .lStructSize = Len(OFN)
        .hwndOwner = hwnd
        .strFilter = Filter
        .nFilterIndex = FilterIndex
        .strFile = strFilename
        .nMaxFile = Len(strFilename)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .strTitle = DialogTitle
        .Flags = Flags
        .strDefExt = DefaultExt
        .strInitialDir = InitialDir
        ' Didn't think most people would want to deal with
        ' these options.
        .hInstance = 0
        '.strCustomFilter = ""
        '.nMaxCustFilter = 0
        .lpfnHook = 0
        'New for NT 4.0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
    End With
    ' This will pass the desired data structure to the
    ' Windows API, which will in turn it uses to display
    ' the Open/Save As Dialog.
    If OpenFile Then
        fResult = aht_apiGetOpenFileName(OFN)
    Else
        fResult = aht_apiGetSaveFileName(OFN)
    End If
 
    ' The function call filled in the strFileTitle member
    ' of the structure. You'll have to write special code
    ' to retrieve that if you're interested.
    If fResult Then
        ' You might care to check the Flags member of the
        ' structure to get information about the chosen file.
        ' In this example, if you bothered to pass in a
        ' value for Flags, we'll fill it in with the outgoing
        ' Flags value.
        If Not IsMissing(Flags) Then Flags = OFN.Flags
        ahtCommonFileOpenSave = TrimNull(OFN.strFile)
    Else
        ahtCommonFileOpenSave = vbNullString
    End If
End Function
 
Function ahtAddFilterItem(strFilter As String, _
    strDescription As String, Optional varItem As Variant) As String
' Tack a new chunk onto the file filter.
' That is, take the old value, stick onto it the description,
' (like "Databases"), a null character, the skeleton
' (like "*.mdb;*.mda") and a final null character.
 
    If IsMissing(varItem) Then varItem = "*.*"
    ahtAddFilterItem = strFilter & _
                strDescription & vbNullChar & _
                varItem & vbNullChar
End Function
 
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
    intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
        TrimNull = Left(strItem, intPos - 1)
    Else
        TrimNull = strItem
    End If
End Function
 
Sub test()
MsgBox Get_Filename(False, , , "doodah.msg")
End Sub

Open in new window