I'd like to make an Outlook macro to resize attached JPG files that are larger than 100 KB. This is for received messages that are in the inbox, not messages that are being sent.
I have code to find attached JPG files over a set size but am not sure of how to resize them and then save the image back as an attachment.
Sub ResizeAttachedImage()
Dim objMSG As Outlook.MailItem
Dim oAtt As Outlook.Attachments
Dim oFile
Dim extn As String
Dim sz As Long
'Get the source email
Select Case Application.ActiveWindow.Class
Case olExplorer
Set objMSG = ActiveExplorer.Selection.Item(1)
objMSG.Display
Case olInspector
Set objMSG = ActiveInspector.CurrentItem
End Select
Set oAtt = objMSG.Attachments
For Each oFile In oAtt 'loop through the list of file attachments
'get the file extension
extn= Right$(oFile.FileName, Len(oFile.FileName) - InStrRev(oFile.FileName, "."))
If LCase(extn) = "jpg" Then 'process only jpg files
sz = oFile.Size / 1024 'file size in kb
If sz > 100 Then
MsgBox (oFile.FileName + " is " + Str(sz) + " KB and needs to be resized") 'oFile.FileName
'how to resize attached images to 50%
End If
End If
Next
End Sub
OOM would not let you modify an existing attachment. The only way is to delete the old attachment (Attachment.Delete) and add a new one back (MailItem.Attachments.Add). If you are modifying an embedded image attachment, make sure to reset the PR_ATTACH_CONTENT_ID MAPI property (DASL name http://schemas.microsoft.com/mapi/proptag/0x3712001F) to its original value using Attachment.PropertyAccessor.SetProperty. If PR_ATTACH_CONTENT_ID is missing, PR_ATTACH_CONTENT_LOCATION (DASL name http://schemas.microsoft.com/mapi/proptag/0x3713001F) might also have to be set.
If using Redemption is an option (disclosure: I am its author), it exposes raw attachment data as RDOAttachment.AsText / AsArray / AsStream, so the attachment would not have to be removed and then added back.
Related
I want to encrypt whenever an attachment with PDF extension is added to mail with Outlook vba.
Is there a way to write such a macro?
Thanky you?
You can handle the MailItem.AttachmentAdd event which is fired when an attachment has been added to an Outlook item. So, you could check the attached file - the Attachment that was added to the item is passed as a parameter and encrypt it if required. For example:
Public WithEvents newItem As Outlook.MailItem
Private Sub newItem_AttachmentAdd(ByVal newAttachment As Attachment)
If newAttachment.Type = olByValue Then
newItem.Save
If newItem.Size > 500000 Then
MsgBox "Warning: Item size is now " & newItem.Size & " bytes."
End If
End If
End Sub
Public Sub TestAttachAdd()
Dim atts As Outlook.Attachments
Dim newAttachment As Outlook.Attachment
Set newItem = Application.CreateItem(olMailItem)
newItem.Subject = "Test attachment"
Set atts = newItem.Attachments
Set newAttachment = atts.Add("C:\Test.txt", olByValue)
End Sub
Note, you can find the cached file on disk. You can find the actual path in the windows registry:
I have a vbscript macro that I'm using in Outlook. It moves a mailitem to some folder, say X. After I run the macro and I try to manually move a mailitem from Outlook with Control-v, it defaults to folder X. I would like Control-v to default to the folder that it would have used before I ran the macro.
Is there some way in VBScript to find out what folder the last mailitem was move to, and to return that to be the default folder after I run my script? Or is there a way to move a mailitem in my script without the destination folder being remembered by Outlook Control-v after I run the script?
Thanks for any hints.
OK, here is the code I'm using. It is a macro to save a mailitem as HTML and open it in a browser. I save any attachments in a separate directory and I add in a list of URLs to the attachments. I do this by modifying the mailitem, but I don't want change the original message - I want it to remain in my inbox as it was. So I create a copy and when I'm done I want to get rid of the copy. For some reason the .Delete method just doesn't do anything. So, one solution for me would be to figure out why .Delete is not working. I created a work-around by just moving the copied message into my deleted items folder. The problem I have with this is that I often use control-v to move items from my inbox to an archive folder. Once I run the macro, though, the default folder for control-v is the deleted item folder. I keep archiving items there by mistake. So the best solution would be to get .Delete working, but even then, that might change the control-v default behavior after running the macro.
Here's the code. I've only been doing vba for a couple of days, so any tips on things I'm missing appreciated.
Option Explicit
Sub CreateHTML()
Select Case TypeName(Outlook.Application.ActiveWindow)
Case "Inspector"
CreateHTMLfromObject Outlook.Application.ActiveInspector.CurrentItem
Case "Explorer"
Dim objItem As Object
For Each objItem In Outlook.Application.ActiveExplorer.Selection
CreateHTMLfromObject objItem
Next
End Select
End Sub
Sub CreateHTMLfromObject(objItem As Object)
' For now, assume all items are mail items
'Select Case objItem.Class
'Case olMail
Dim objMailOrig As MailItem
Dim objMailCopy As MailItem ' Work on a copy of the message
Set objMailOrig = objItem
Set objMailCopy = objMailOrig.copy
' Where all HTML versions of messages will be stored
Dim fileDir As String
fileDir = "C:\Lib\olHTML\"
' A unique message id from the original message
Dim MsgId As String
MsgId = objMailOrig.EntryID
' The file the HTML version of the message will be stored in
Dim fileName As String
fileName = MsgId & ".html"
' The full file system path where the HTML verison of the message will be stored
Dim filePath As String
filePath = fileDir & fileName
' ---------------------------------------------------------------
' Save Attachments
' ---------------------------------------------------------------
' Subdirectory for attachments on this message
' A unique subdirectory for each message
Dim atmtDir As String
atmtDir = MsgId & "_atmt\"
' Full file system path to the attachment directory
Dim atmtDirPath As String
atmtDirPath = fileDir & atmtDir
' File system object for creating the attachment folder
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
If (objMailCopy.Attachments.Count > 0) And (Not oFSO.FolderExists(atmtDirPath)) Then
oFSO.CreateFolder (atmtDirPath)
End If
' To hold the full file system path to each attachment file
Dim atmtFilePath As String
' String to accumulate HTML code for displaying links to attachments
' in the body of the HTML message
Dim atmtLinks As String
atmtLinks = " "
Dim atmt As Attachment
For Each atmt In objMailCopy.Attachments
atmtFilePath = atmtDirPath & atmt.fileName
atmt.SaveAsFile atmtFilePath
' create a relative URL
atmtLinks = atmtLinks & _
"<br><a href='" & atmtDir & atmt.fileName & "'>" & atmt.fileName & "</a>"
Next atmt
' ---------------------------------------------------------------
' Add links to attachments
' ---------------------------------------------------------------
' This changes the original message in Outlook - so we work on a copy
' Convert body to HTML if RTF, Text or other format
If (objMailCopy.BodyFormat = olFormatPlain Or olFormatRichText Or olFormatUnspecified) Then
objMailCopy.BodyFormat = olFormatHTML
End If
' Add attachments links at the beginning
If objMailCopy.Attachments.Count > 0 Then
objMailCopy.HTMLBody = _
"<p>" & "Attachments: " & atmtLinks & "</p>" & objMailCopy.HTMLBody
End If
' ---------------------------------------------------------------
' Save the HTML message file
' ---------------------------------------------------------------
objMailCopy.SaveAs filePath, olHTML
' ---------------------------------------------------------------
' Delete the copy from Outlook
' ---------------------------------------------------------------
'! This seems to have no effect
' objMailCopy.Delete
' Move copied message to deleted items folder
objMailCopy.Move Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems)
' ---------------------------------------------------------------
' Open the HTML file with default browser
' ---------------------------------------------------------------
Dim url As String
url = "file:///" & filePath
CreateObject("WScript.Shell").Run (url)
End Sub
i would not make a copy in the inbox and delete that afterwards (that will make your deleted-folder explode one day), but make your changes in the local copy of the message-file:
here an example:
Sub changelocalcopy(olitem As Outlook.MailItem)
Dim oNamespace As Outlook.NameSpace
Set oNamespace = Application.GetNamespace("MAPI")
Dim oSharedItem As Outlook.MailItem
Dim pfaddatei As String
pfaddatei = c:\test.msg 'path for your local copy here
olitem.SaveAsFile pfaddatei
Set oSharedItem = oNamespace.OpenSharedItem(pfaddatei)
'now do your changes
'you will not want the following line, I leave it here in case you Need it:
Kill pfaddatei
oSharedItem.Close (olDiscard)
Set oSharedItem = Nothing
Set oNamespace = Nothing
End Sub
Our firewall users send messages requesting unblocking certain websites that they believe shouldn't be blocked. Their messages subject fields contain such websites urls. In fact, one url is sent per message. Due to the increase in number of users, hundreds or may be thousands of messages are expected to be received per day.
Is there an Outlook macro that will collect or extract such urls (from received messages subject fields) into one single text file without having to open any message?
Deeply appreciating any assistance with this matter.
Thanks in advance
Please write this code to your Outlook VBA module. Change some names of folders and destination file in some lines below. For other information see comments inside sub.
Sub Retrieve_http()
'our Outlook folder- deifinitions
Dim myItem As MailItem
Dim myFolder As Folder
Dim myNamespace As NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
'put your folders name here
'1st one is store folder which should refer to firewall_support#iuass.org
'second is possibly 'inbox folder'
Set myFolder = myNamespace.folders("firewall_support#iuass.org").folders("inbox")
'destination file
Dim resFile As String
resFile = "c:\Users\Kazik\Desktop\httpRequest.txt"
Dim ff As Byte
ff = FreeFile()
'creating or opening it- each time you run this macro we will append data
'until deletion of either file or its content
Open resFile For Append As #ff
For Each myItem In myFolder.items
If InStr(1, myItem.Subject, "http://") > 0 And _
InStr(1, myItem.Subject, "classified under:") > 0 Then
'write to file
Write #ff, myItem.Subject
End If
Next
Close #ff
End Sub
EDIT to include appropriate deletion process and reference of the code to the picture.
The following picture present Outlook window (Polish version) where: Business Mail is one of Top Folders (which refers to separate .pst file). 'Skrzynka odbiorcza' is just 'inbox'.
Code which searches for certain emails, retrieves subject of emails and deletes emails afterwards looks as follow:
Sub Retrieve_http()
'our Outlook folder- deifinitions
Dim myItem As MailItem
Dim myFolder As Folder
Dim myNamespace As NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
'put your folders name here
Set myFolder = myNamespace.folders("Business Mail").folders("skrzynka odbiorcza")
'destination file
Dim resFile As String
resFile = "c:\Users\Kazik\Desktop\httpRequest.txt"
Dim ff As Byte
ff = FreeFile()
'creating or opening it- each time you run this macro we will append data
'until deletion of either file or its content
Open resFile For Append As #ff
Dim i!
For i = myFolder.items.Count To 1 Step -1
If InStr(1, myFolder.items(i).Subject, "http://") > 0 And _
InStr(1, myFolder.items(i).Subject, "classified under") > 0 Then
'write to file
Write #ff, myFolder.items(i).Subject
'delete item
myFolder.items(i).Delete
End If
Next
Close #ff
End Sub
here is the solution to your problem :)
When you make a For Each Outlook it enumerating each email.
If you move any email within the loop For Each, then Outlook changes the number of all the emails of the folder but doesn't change the iteration number of your loop. This results in several messages that will not be read.
Solution is to make a loop starting from the last email as mentioned here
Outlook macro to collect/extract data from "Subject field" of numerous messages into a text file
CODE:
Replace (For Each InboxMsg In Inbox.Items) with
For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
I wanted to develop VBA code that:
Loops through all email items in mailbox
If there are any type of other items say "Calendar Invitation" skips that item.
Finds out the emails with attachments
If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.
Code works perfect EXCEPT;
For example
There are 8 email received with ".xml" file attached to each one of them in your mailbox.
run the code
you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.
Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.
BTW, this code runs every time I open the Outlook.
Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps
'Process XML emails
Dim InboxMsg As Object
Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder
Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode
'Specify the folder where the attachments will be saved
fPathTemp = "some directory, doesn't matter"
fPathXML_SEM = "some directory, doesn't matter"
fPathEmail_SEM = "some directory, doesn't matter"
'Setup Outlook
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")
'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
'On Error Resume Next
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
'Check for xml attachement
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
'Load XML and test for the title of the file
MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
xmlDoc.Load fPathTemp & MsgAttachment.FileName
Set xmlTitle = xmlDoc.SelectSingleNode("//title")
Select Case xmlTitle.Text
Case "specific title"
'Get supplier number
Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
'Save the XML to the correct folder
MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
'Save the email to the correct folder
InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
'Delete the message
InboxMsg.Move DeletedItems
Case Else
End Select
'Delete the temp file
On Error Resume Next
Kill fPathTemp & MsgAttachment.FileName
On Error GoTo 0
'Unload xmldoc
Set xmlDoc = Nothing
Set xmlTitle = Nothing
Set xmlSupNum = Nothing
End If
Next
End If
Next
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
'Clean-up
Set InboxMsg = Nothing
Set DeletedItems = Nothing
Set MsgAttachment = Nothing
Set ns = Nothing
Set Inbox = Nothing
i = 0
End Sub
Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Each construct (and it doesn't seem to be consistent either).
Likely solution: Replace
For Each InboxMsg In Inbox.Items
with
For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.
It's often not a good idea to modify the contents of a (sub)set of items while looping over them. You could modify your code so that it first identifies all of the items that need to be processed, and adds them to a Collection. Then process all the items in that collection.
Basically you shouldn't be removing items from the Inbox while you're looping through its contents. First collect all the items you want to process (in your Inbox loop), then when you're done looping, process that collection of items.
Here's some pseudo-code which demonstrates this:
Private Sub Application_Startup()
Dim collItems As New Collection
'Start by identifying messages of interest and add them to a collection
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
collItems.Add InboxMsg
Exit For
End If
Next
End If
Next
'now deal with the identified messages
For Each InboxMsg In collItems
ProcessMessage InboxMsg
Next InboxMsg
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
End Sub
Sub ProcessMessage(InboxMsg As Object)
'deal with attachment(s) and delete message
End Sub
I have a created folder in my outlook named "Reports". This folder contains emails with one attachment in each email. I would like to use ACCESS VBA to save the attachments from the "Reports" folder in Outlook to a local drive in my computer. here is the code I have so far, but gives me errors. Please help:
Sub GetAttachments()
Dim ns As NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim folder As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("Reports") // I get an error in this line says an object could not be found
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Automation\" & Atmt.FileName
Atmt.SaveAsFile FileName // here is another error says method is not found
i = i + 1
Next Atmt
Next Item
Is your Reports folder within your Inbox folder? You may need to do something like this:
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set RptFolder = Inbox.Folders("Reports")
Your syntax for saving attachments looks correct (apart from your comments not being correct for VBA). You could print out the Filename that you are creating to see if it's a valid name. And I assume that you have created the Automation folder that you mention.
Update:
Try declaring your Atmt as an Outlook.Attachment. There is such a thing as an Access.Attachment which does not have a SaveAsFile method, and it's probably picking that one up first. If you include the library name, you should get the one you need.
Update 2:
To get to your Reports folder, one way is to get the Inbox folder as you are currently doing, then get its parent, then get the Reports folder under that.
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set Mailbox = Inbox.Parent
Set RptFolder = Mailbox.Folders("Reports")
Another way would be to scan the items under "ns" to find the one that starts with "Mailbox", then get the Reports folder under that. It seems a little more cumbersome than getting the parent of the inbox. That also seems cumbersome, but I couldn't find a way to get to the Mailbox folder directly.
Replace
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Automation\" & Atmt.FileName
Atmt.SaveAsFile FileName // here is another error says method is not found
i = i + 1
Next Atmt
With.....
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Automation\" & Atmt.FileName
Attachments.SaveAsFile FileName // here is another error says method is not found
i = i + 1
Next Atmt
Outlook does not have a problem with atmt in the reference however, MS Access does. This should fix your problem.
Davis Rogers
Replace
Dim Atmt As Attachment
with
Dim Atmt As Outlook.Attachment
It'll make Access find the correct Class for atmt.