I'm writing some code to save Outlook emails and I need to know the number of attachments. To get an attachment count have this code. When there are no attachments nAttach is 0 as expected but when there are n attachments I get n+1. I tried using nAttach -1 to correct it but then it bumped up again or sometimes if i have 1 attachment it would come out to 0.
Dim oMail As Outlook.MailItem
Dim sAttach As String
Dim nAttach As Integer
nAttach = oMail.Attachments.Count
If nAttach > 0 Then nAttach = nAttach - 1
sAttach = CStr(nAttach)
The attachment count is most likely right. Note that embedded HTML images can be attachments even if Outlook does not show them in the list of attachments.
Related
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.
I'd like to list all of my emails in a specific folder by using Outlook MAPI. I have tried the following code,
but it only shows 400 out of the 20,000 emails in the folder. I would greatly appreciate it if anyone could please show me how to list all of the emails.
Sub EmailListinFolder()
Dim mn As Long
Dim Message As String
Dim item As Object
Dim NS As Object
Dim Folder As Object
'Get the MAPI Name Space
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
'Allow the user to select a folder in Outlook
Set Folder = NS.PickFolder
For Each item In Folder.Items
If item.Class = olMail Then
Message = item.Subject & "|" & item.CreationTime
If Len(Message) Then
mn = mn + 1
End If
End If
Next item
MsgBox (mn)
End Sub
Is that an online profile? Most likely you end up opening too many items (for each loop keeps all items referenced until the loop exits). Use Table object instead - see example at https://msdn.microsoft.com/VBA/Outlook-VBA/articles/folder-gettable-method-outlook.
So here's an interesting problem I stumbled upon on. I’m running into issues by sending emails out to SpiceWorks and Mac users.
When a user has a problem they will email Help Desk. We setup a personal Outlook email to handle Help Desk tickets. Once the ticket hits the outlook mailbox it will automatically be sent to our SpiceWorks site.
Now all of our emails have signatures and there are certain signatures with small png image logos (Youtube, LinkedIn, Facebook, and Twitter).
When the email hits SpiceWorks it uploads those png images as attachments. These attachments cause most of the problems because some email threads get very long before they even get submitted as an help desk ticket. They would end up with maybe 20+ attachments of the same four logo png's.
I coded to remove all attachments to that specific address but some users send actual attachments. I tried remove the specific attachments by name but if there are duplicates of same .png image they would just iterate. (img001 through img004 is now img005 through img009)
I found the current VBA script in the HelpDesk Outlook. I was told that Outlook has to be running all the time in order for it to work... sometimes.
I started writing my own script where it checks if the current email is going to HelpDesk email address then remove the attachemnts. No luck yet.
Current Code
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim msg As Outlook.MailItem
Dim recips As Outlook.Recipients
Dim str As String
Dim emailAddress As String
Dim prompt As String
Dim msgbody As String
msgbody = Item.Body
Set msg = Item 'Subject Message
Set recips = msg.Recipients
str = "HelpDesk"
For x = 1 To GetRecipientsCount(recips)
str1 = recips(x)
If str1 = str Then
'MsgBox str1, vbOKOnly, str1 'For Testing
prompt = "Are you sure you want to send to " & str1 & "?" 'For Testing
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then 'For Testing
Cancel = True
End If
'if attachments are there
If Item.Attachments.Count > 0 Then
'for all attachments
For i = Item.Attachments.Count To 1 Step -1
'if the attachment's filename is similar to "image###.png", remove
If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
MsgBox ("Item Removed " + Item.Attachments(i))
Item.Attachments.Remove (i)
End If
Next
End If
End If
Next x
End Sub
Public Function GetRecipientsCount(Itm As Variant) As Long
' pass in a qualifying item, or a Recipients Collection
Dim obj As Object
Dim recips As Outlook.Recipients
Dim types() As String
types = Split("MailItem, AppointmentItem, JournalItem, MeetingItem, TaskItem", ",")
Select Case True
' these items have a Recipients collection
Case UBound(Filter(types, TypeName(Itm))) > -1
Set obj = Itm
Set recips = obj.Recipients
Case TypeName(Itm) = "Recipients"
Set recips = Itm
End Select
GetRecipientsCount = recips.Count
End Function
A few questions:
1.) Is there a way to set rules in outlook(Looked at numerous possibilities) or do something with the Exchange Server to stop this from happening?
2.) With Vba is there a way to remove or not allow a signature when the email is sent?
If anything, my ultimate goal is just to prevent those .png's being uploaded as images to Mac users and SpiceWorks.
I'm sure there is more to this but I will gladly answer any questions given to me.
Thank you for any help or directions!
If I understand you correctly, you're trying to remove .png files being sent to SpiceWorks. If so, use the macro below from the Outlook mailbox sending to SpiceWorks. On the ItemSend event, this will check the filename of all attachments and remove those with .png extensions. If this is not what you're trying to do, post back here. Thanks.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'if attachments are there
If Item.Attachments.count > 0 Then
'for all attachments
For i = Item.Attachments.count To 1 Step -1
'if the attachment's extension is .png, remove
If Right(Item.Attachments(i).FileName, 4) = ".png" Then
Item.Attachments.Remove (i)
End If
Next
End If
End Sub
----- updated to only remove attachments that look like "image###.png" -----
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'if attachments are there
If Item.Attachments.count > 0 Then
'for all attachments
For i = Item.Attachments.count To 1 Step -1
'if the attachment's filename is similar to "image###.png", remove
If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
Item.Attachments.Remove (i)
End If
Next
End If
End Sub
----- updated to only remove attachments that are <10kb and look like "image###.png"-----
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'if attachments are there
If Item.Attachments.count > 0 Then
'for all attachments
For i = Item.Attachments.count To 1 Step -1
'if attachment size is less than 10kb
If Item.Attachments(i).Size < 10000 Then
'if the attachment's filename is similar to "image###.png", remove
If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
Item.Attachments.Remove (i)
End If
End If
Next
End If
End Sub
I have searched for a solution to this, but no luck. I know it will be code based, but I'm really not sure where to start with it.
Here is the problem:
Input: 1 zip file containing multiple (upwards of 50) separate "Outlook Items"
Each outlook item opens up into an email that has an attachment on it.
Output: 1 file with all attachments from the Outlook items inside of it.
Example:
input:
Myzip.zip ->
Mail_item1.msg
Mail_item2.msg
Mail_item3.msg
output:
MyOutputFile ->
mail_item1_attachment.pdf
mail_item2_attachment.pdf
mail_item3_attachment.pdf
any guidance is appreciated. My only thoughts thus far are outlook VBA (can this access multiple .msg items in a folder on the C drive?)
Here is what I have so far:
Sub get_attachments_from_mailItems()
Dim inPath As String
Dim outPath As String
Dim msg As MailItem
Dim doc As Attachment
'What do I dim the following as?
Dim input_folder
Dim output_folder
Dim attachments 'collection? array?
inPath = "C:\temp\input"
outPath = "C:\temp\output"
'--I need most help with the folder objects and how to create them/use them --
'Open input folder as object
'open output folder as object
For Each msg In input_folder
'check message for attachments, then loop if there are
For Each doc In attachments
'Save attachment in output_folder
Next
Next
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)