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
Sub Save()
Dim theSel As Outlook.Selection
Set theSel = Application.ActiveExplorer
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
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
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.
ASKER
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.
Is that to do with the manner they have their outlook set up.
ASKER
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.
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.
ASKER
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.
ASKER
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.Bo dyFormat)
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(varFor mat) As Integer
Select Case intFormat
Case olFormatRichText
DetermineBodyFormat = olRTF
Case olFormatHTML
DetermineBodyFormat = olHTML
Case olFormatPlain
DetermineBodyFormat = olText
End Select
End Function
Sub SaveFile()
Dim theSel As Outlook.Selection, _
itm As MailItem, _
itmAttachment As Attachment, _
strFilename As String
Set theSel = Application.ActiveExplorer
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.Bo
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(varFor
Select Case intFormat
Case olFormatRichText
DetermineBodyFormat = olRTF
Case olFormatHTML
DetermineBodyFormat = olHTML
Case olFormatPlain
DetermineBodyFormat = olText
End Select
End Function
ASKER
I think it might be just one individual that it does not seem to work with
ASKER
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
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.
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.
ASKER
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
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?
ASKER
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:\Te sting\Stat ionery1.ht m")
strBuffer = objFile.ReadAll
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
Set olMessage = Application.CreateItem(olM ailItem)
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(strPat h) Then
strPath = strPath & "(" & Date & "@" & Time & ")"
End If
objFSO.CreateFolder strPath
strFilename = strPath & "\" & Replace(itm.Subject, ":", " ") & ".txt"
itm.SaveAs strFilename, DetermineBodyFormat(itm.Bo dyFormat)
If itm.Attachments.Count > 0 Then
Set objMsgFile = objFSO.OpenTextFile(strFil ename, 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(varFor mat) As Integer
Select Case intFormat
Case olFormatRichText
DetermineBodyFormat = olRTF
Case olFormatHTML
DetermineBodyFormat = olHTML
Case olFormatPlain
DetermineBodyFormat = olText
End Select
End Function
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:\Te
strBuffer = objFile.ReadAll
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
Set olMessage = Application.CreateItem(olM
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
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(strPat
strPath = strPath & "(" & Date & "@" & Time & ")"
End If
objFSO.CreateFolder strPath
strFilename = strPath & "\" & Replace(itm.Subject, ":", " ") & ".txt"
itm.SaveAs strFilename, DetermineBodyFormat(itm.Bo
If itm.Attachments.Count > 0 Then
Set objMsgFile = objFSO.OpenTextFile(strFil
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(varFor
Select Case intFormat
Case olFormatRichText
DetermineBodyFormat = olRTF
Case olFormatHTML
DetermineBodyFormat = olHTML
Case olFormatPlain
DetermineBodyFormat = olText
End Select
End Function
ASKER
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.
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.
ASKER
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?
ASKER
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
Sub SaveFile()
Dim theSel As Outlook.Selection, _
itm As MailItem, _
itmAttachment As Attachment, _
strFilename As String
Set theSel = Application.ActiveExplorer
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
ASKER