I was looking for any options on a browse for folder within Outlook VBA. Currently I have, from a previous search:
Dim save_to_folder As String
save_to_folder = InputBox("Search returned " & objRsts.Count & " messages._
Please input folder location")
olkMsg.SaveAs save_to_folder & "\" & strDateName & " " & strFileName & ".msg"
Where strDateName and strFileName are modified subjects and dates of the emails.
My problem is that I would like a browse option along with manually typing to prevent typos. I'm very new to VBA and need to auto-save emails very often, please let me know what my options are.
You could set up your code so you choose between InputBox and BrowseForFolder.
You could set these up separately.
I suggest you could use BrowseForFolder exclusively.
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim save_to_folder As Object
Set save_to_folder = _
oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
If save_to_folder Is Nothing Then Exit Sub
' Note: BrowseForFolder doesn't add a trailing slash
Sample code here Macro to move selected outlook emails
Related
I am new at using macros. I tried making a simple code where a macro would save my part in different formats. stp, igs and 3dxml.
Sub CatMain()
pathInputBox = InputBox("Enter path")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = objFSO.GetFolder(pathInputBox)
CATIA.DisplayFileAlerts = False
For Each oFile In oFolder.Files
If Right(oFile.Name, 8) = ".CATPart" Then
Set oProdDoc = CATIA.Documents.Open(oFolder & "\" & oFile.Name)
newname = Replace(oFile.Name, ".CATPart", "")
oProdDoc.ExportData oFolder & "\" & newname, "stp"
oProdDoc.ExportData oFolder & "\" & newname, "igs"
oProdDoc.ExportData oFolder & "\" & newname, "3dxml"
End If
Next
End Sub
And it works. But what if my part has more bodies. Say I also have an unfolded as a body and I would want to save that separately too? How would a macro code look if I wanted to save a body from the catpart? Can someone help me with this simple operation?
ExportData exports only geometry that is visible.
The simplest way would be to show only one body and hide all others.
To do this, select the body and show or hide it using the VisProperties (setShow).
My goal is to extract the .png files of emails in the Outlook Inbox sub folder named Infuse Energy Daily Usage Reports.
The emails each contain six png files. The largest is the only one I need; it is exactly 37.6KB. The next largest file is 22.5KB. The third largest is 18.2KB.
The code mostly does what I need.
I want to add the full subject of the email to the beginning of the file name.
The file name should be:
"Email Subject, Creation Time ("yyyymmdd_hhnnss_"), Original File Name of PNG Image."
Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Infuse Eneregy Daily Usage Reports" folder) for messages with attached
' files of a specific type (here file with a "png" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Infuse Energy Daily Usage Reports") ' Enter correct subfolder name.
i = 0
' Check subfolder for messages and exit if none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Infuse Energy Daily Usage folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "png" extension
If Right(Atmt.FileName, 3) = "png" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Desktop\Energy Comparisons\Infuse Reports (from email)\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the Infuse Reports (from email)." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Desktop\Energy Comparisons\Infuse Reports (from email)", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub
First of all, there is no need to iterate over all items in a folder:
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
This is not really a good idea because it can take a lot of time to iterate over all items in a folder. Instead, you need to use the Find/FindNext or Restrict methods of the Items class. Filter Example: [Attachment & Subject Like '%keyword%']
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " Like '%keyword%' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1"
Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
As for the filename of attachments saved to the disk, you need to make sure there are no forbidden symbols included to the filename before calling the SaveAsFile method.
If Right(Atmt.FileName, 3) = "png" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Desktop\Energy Comparisons\Infuse Reports (from email)\" & Item.Subject & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Also be aware, an Outlook folder may contain different kind of items. I'd suggest checking the item's type at runtime to make sure you deal with mail items only. The Class property returns an OlObjectClass constant indicating the object's class. Or just use the following condition:
If TypeOf Item Is MailItem Then
' your code here
End If
I have an email message with an image attachment that I want to save with a VBA macro. The file name and the display name show French accents in the attachment name (e.g. "Événement.jpg").
Saving the attachment with Outlook VBA works:
Dim fso As Object
Dim sFileName As String
Dim oAttachment As Outlook.attachment
set fso = CreateObject("Scripting.FileSystemObject")
' Edit the folder location accordingly:
sFileName = "C:\Users\YOUR_ACCOUNT_HERE\Desktop\" & oAttachment.getFileName
oAttachment.SaveAsFile sFileName
I can see the file correctly named on the file system.
Trying to access this file within VBA later on fails. The following code always returns FALSE:
' Returns False
MsgBox "File [" & sFileName & "] exists? " & sfo.fileexists(sFileName), vbInformation
Dim bFileExists as Boolean
If lenB (Dir(sFileName) > 0 Then
bFileExists = True
Else
bFileExists = True
EndIf
' Also returns False
MsgBox "File [" & sFileName & "] exists? " & bFileExists, vbInformation
What am I doing wrong?
I eventually came upon a workaround, thanks to the MS-DOS "8.3" file naming legacy of Windows. Converting the file name to its short file name makes Dir() and Open() happy:
Dim sFileShortName As String
sFileShortName = fso.Getfile(sTempFileLocation).shortpath
bFileExists = (Dir(sFileShortName) <> "") ' Now returns True at last!
Now fso.FileExists(sFileShortName) as well as bFileExists (based on Dir()) return True and Open sFileShortName For Binary Access Read As lFileNum works as well.
I hope that this will be beneficial to others.
Saving a file attachment in an Outlook mail item with the VBA method Attachment.SaveAsFile() call produces the expected result (file saved with same filename on the filesystem), even for file names with non-ASCII characters.
However, VBA apparently stores the file name in a 16-bit composite format String where accented letters are stored as a (letter, accent) pair. I can't find a way to output the string inside the message body with accented letters showing up as one glyph ("é") instead of two ("e´").
Concretely, the attachment is properly saved under the correct file name on disk when using the following code:
' Save the Outlook attachment
oAttachment.SaveAsFile (sTempFileLocation)
This results in a file being written to the folder specified in sTempFileLocation and the file name complies with the way it appears in the Outlook message (accents, non-ASCII characters etc).
However, when retrieving and manipulating the file name, it appears that a 16-bit composite internal representation of special characters is used. This means that the file name "à présent.txt" is displayed as "a` pre´sent.txt" (accented characters are represented with the character + the accent in 2 consecutive bytes).
For instance:
sAttachmentName = fso.getfilename(sTempFileLocation)
Debug.Print ("Attachment name = [" & sAttachmentName & "]")
will result in:
Attachment name = [a` pre´sent.txt]
There is little information available on this matter, all I found so far was this MSDN link describing the MultiByteToWideChar() function. From there it appears that the 16-bit internal VBA rendering happens implcitly and is even computer dependent (depending on code page and locale in use).
Here follows a self-contained minimalistic example that tries to save the email attachments of the first selected message to your My Documents folder unless it already exists:
Sub SaveMessageAttachments()
Dim objApp As Outlook.Application
Dim oSelection As Outlook.Selection
Dim aMail As Outlook.MailItem
Dim fso As Object
On Error Resume Next
' Instantiate an Outlook Application object.
Set objApp = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set oSelection = objApp.ActiveExplorer.Selection
If oSelection Is Nothing Then
Exit Sub
End If
' Select the 1st mail item in the current selection
Set aMail = oSelection.item(1)
Dim sAttachmentFolder As String
' Get the path to your "My Documents" folder
sAttachmentFolder = CreateObject("WScript.Shell").SpecialFolders(16)
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oAttachments As Outlook.Attachments
Dim lItemAttachmentCount As Long
Set oAttachments = aMail.Attachments
lItemAttachmentCount = oAttachments.Count
If (lItemAttachmentCount > 0) Then
Dim lAttachmentIndex As Long
For lAttachmentIndex = 1 To lItemAttachmentCount
Dim oAttachment As Outlook.attachment
Set oAttachment = oAttachments.item(lAttachmentIndex)
Dim sFileName As String
sFileName = oAttachment.FileName
If LenB(sFileName) > 0 Then
Dim sFilePath As String
sFilePath = sAttachmentFolder & "\" & sFileName
If fso.fileexists(sFilePath) Then
MsgBox "Cannot save attachment " & lAttachmentIndex & vbCr _
& "File already exists: " & vbCr _
& sFilePath, vbExclamation + vbOKOnly
Else
If MsgBox("Saving atachment " & lAttachmentIndex & "?" & vbCr _
& "Save location: " & vbCr & sFilePath, _
vbQuestion + vbOKCancel) = vbOK Then
' Save the attachment to the temporary folder
oAttachment.SaveAsFile (sFilePath)
Dim sAttachmentName As String
sAttachmentName = fso.getfilename(sFilePath)
Dim lAttachmentLength As Long
lAttachmentLength = fso.getfile(sFilePath).size
Dim sURL As String
sURL = "file://" & Replace(sFilePath, "\", "/")
MsgBox "Attachment " & lAttachmentIndex _
& " saved as: " & sAttachmentName & vbCr _
& "Size: " & lAttachmentLength & vbCr _
& "URL = " & sURL, _
vbInformation + vbOKOnly
End If
End If
End If
Next lAttachmentIndex
End If
End Sub
As you will see, the SaveMessageAttachments() subroutine correctly saves the file to the filesystem, with the proper file name. However, Outlook dialogs (as well as when trying to write the attachment file name or URL to the message body in VBA) will always render the file names having accents differently. Please give it a try with an Outlook message having an attachment named e.g. "à présent.txt").
What is strange, however, is that if I try to paste sURL in the message body, although the URL is incorrectly written (2 character decomposition of accented letters) Outlook seems to find and open the file.
How can I transform this accented string (sAttachmentName) with VBA in order to correctly paste it ("à présent.txt" instead of "a` pre´sent.txt") into the message body?
I'm looking for a starting point here, so no code to post I'm afraid !
I would like (if possible) to be able to open an email in Outlook (in the normal way, from the front-end), and then click a button to run a macro, which will extract the attachments from this email and save them to a directory path (derived from the subject).
Sound do-able ?
Any pointers, links code snippets welcome !
Okay, I got as far as the saving to local folder and deleting from message. I haven't worked out buttons yet, but I'm sure it's not the hardest thing in the world...
So I would check out the VBA documentation on Attachment Methods, specifically the one on SaveAsFile, as it has a full example that I used to test things out. The two methods available are the exact ones you need:
SaveAsFile
and
Delete
But since VBA makes nothing simple, using those two lines requires 15 others.
Also there is a REALLY great site called outlookcode.com. The site admin is a VBA/Outlook wizard and she will personally answer your questions if they sit on the forums for a more than a day (not a guarantee, just my experience). The site is full of sources and other people's code, etc.
Here is what I wrote to try out what you had in mind, based on the sample from MSDN which I added the delete method, making it a one click save/delete:
Sub getAttatchment()
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myItem = myInspector.CurrentItem
Set myAttachments = myItem.Attachments
If myAttachments.Item(1).DisplayName = "" Then
Set myAttachments.Item(1).DisplayName = myAttachments.Item(1).FileName
End If
myAttachments.Item(1).SaveAsFile Environ("HOMEPATH") _
& "\My Documents\" & myAttachments.Item(1).DisplayName
myAttachments.Item(1).Delete
Else
MsgBox "The item is of the wrong type."
End If
End If
End Sub
Be aware that the original sample has a dialog box to ask the user if they are sure they want to save as it will overwrite any files with the same name. I deleted it to simplify the code a bit.
This subroutine will save all attachments found in a user specified Outlook folder to a user specified directory on the file system. It also updates each message with a link to the purged files.
It contains extra comments to help highlight how the .Delete method will shrink Attachment containers dynamically (search for "~~" in the comments).
This subroutine is only tested on Outlook 2010.
' ------------------------------------------------------------.
' Requires the following references:
' Visual Basic for Applications
' Microsoft Outlook 14.0 Object Library
' OLE Automation
' Microsoft Office 14.0 Object Library
' Microsoft Shell Controls and Automation
' ------------------------------------------------------------.
Public Sub SaveOLFolderAttachments()
' Ask the user to select a file system folder for saving the attachments
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim fsSaveFolder As Object
Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
If fsSaveFolder Is Nothing Then Exit Sub
' Note: BrowseForFolder doesn't add a trailing slash
' Ask the user to select an Outlook folder to process
Dim olPurgeFolder As Outlook.MAPIFolder
Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
If olPurgeFolder Is Nothing Then Exit Sub
' Iteration variables
Dim msg As Outlook.MailItem
Dim att As Outlook.attachment
Dim sSavePathFS As String
Dim sDelAtts as String
For Each msg In olPurgeFolder.Items
sDelAtts = ""
' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
' on our olPurgeFolder.Items collection. The collection returned by the Restrict method
' will be dynamically updated each time we remove an attachment. Each update will
' reindex the collection. As a result, it does not provide a reliable means for iteration.
' This is why the For Each style loops will not work. ~~
If msg.Attachments.Count > 0 Then
' This While loop is controlled via the .Delete method which
' will decrement msg.Attachments.Count by one each time. ~~
While msg.Attachments.Count > 0
' Save the attachment to the file system
sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Attachments(1).FileName
msg.Attachments(1).SaveAsFile sSavePathFS
' Build up a string to denote the file system save path(s)
' Format the string according to the msg.BodyFormat.
If msg.BodyFormat <> olFormatHTML Then
sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
Else
sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
End If
' Delete the current attachment. We use a "1" here instead of an "i"
' because the .Delete method will shrink the size of the msg.Attachments
' collection for us. Use some well placed Debug.Print statements to see
' the behavior. ~~
msg.Attachments(1).Delete
Wend
' Modify the body of the msg to show the file system location of
' the deleted attachments.
If msg.BodyFormat <> olFormatHTML Then
msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts
Else
msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>"
End If
' Save the edits to the msg. If you forget this line, the attachments will not be deleted. ~~
msg.Save
End If
Next
End Sub