The following code loops through a folder, creates email with attachment and saves to draft.
Public Sub saveFileTodownload()
Set draftItems = Outlook.Session.Folders("My Email").Folders("Drafts").Items
strFile = Dir("d:\ga\localsdk\")
Do While Len(strFile)
Debug.Print strFile
Set mail = draftItems.Add("IPM.NOTE")
mail.Subject = "1downloadme" & Count
mail.Attachments.Add ("d:\ga\localsdk\" & strFile)
mail.Save
strFile = Dir
Loop
End Sub
I need to wait until the attachment has completely uploaded then call Save.
Is there any way to wait until the attachment has uploaded.
Note: If I debug it and wait a minute after the Attachment.Add line, the attachment has uploaded and Save works.
MailItem.Attachments.Add is synchronous; by the time the call returns, the attachment is added to the message. What makes you believe this is not so?
user93865
I tested your code and it works for me(No error message). However, it will be gets stuck if there are lots of attachments upload.
You could try this code :
Public Sub saveFileTodownload()
Dim store As Outlook.store
Dim space As Outlook.NameSpace
Dim folder As Outlook.folder
Set space = Outlook.Application.GetNamespace("MAPI")
Set store = space.DefaultStore
Set folder = store.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderDrafts)
Set Item = folder.Items.Add("IPM.NOTE")
Item.Subject = "1downloadme"
Item.Body = "one"
Dim r As Long
r = 0
Do While r < 100
Item.Attachments.Add ("C:\Users\temp\Desktop\notes\abd.docx")
r = r + 1
Loop
'Item.Display
Item.Save
Item.Close
End Sub
Related
I need to change the subject line of 1000s of emails in my drafts.
Here is the code I'm using but it's not changing the subject line. Could someone please let me know what I'm missing.
Sub Drafts_Send()
Dim objDrafts As Outlook.Items
Dim objDraft As Object
Dim strPrompt As String
Dim nResponse As Integer
Dim i As Long
Set objDrafts = Outlook.Application.Session.GetDefaultFolder(olFolderDrafts).Items
For i = objDrafts.Count To 1 Step -1
If objDrafts.Item(i).Subject = "Please Thank You" Then
objDrafts.Item(i).Subject = "Please & Thank You"
objDrafts.Item(i).Save
End If
Next i
Set objDrafts = Nothing
End Sub
My guess is that the default Drafts folder is not the folder containing the drafts you wish to update.
Run this macro:
Sub DsplStoreContainingfDefaultDrafts()
Dim NS As Outlook.NameSpace
Dim DefaultInboxFldr As MAPIFolder
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderDrafts)
Debug.Print "Default Drafts folder in """ & DefaultInboxFldr.Parent.Name & """"
End Sub
On my system it outputs:
Default Drafts folder in "Outlook Data File"
“Outlook Data File” is the default store that came with the installation but it is only used for information not associated with an email account. Outlook has created a separate store for each of my email accounts with names like JohnSmith#AcmeIsp.com and JohnSmith#gmail.com. Each of those stores has its own Drafts folder and drafts are in the Drafts folder of the account from which I will send the email.
Go to the folder containing the drafts you wish to update. Is it within the store identified by my macro? If not continue reading.
The complication is that on my system, Drafts is a top level folder in the store for my regular ISP account but a second level folder in folder for my gmail account.
You will need to replace:
Set objDrafts = Outlook.Application.Session.GetDefaultFolder(olFolderDrafts).Items
Outlook.Application. is redundant since you are running this within Outlook.
If you store is like my regular ISP account, you will need something like:
Set objDrafts = Session.Folders("JohnSmith#AcmeIsp.com").Folders("Drafts").Items
If you store is like my gmail account, you will need something like:
Set objDrafts = Session.Folders("JohnSmith#gmail.com").Folders("[Gmail]").Folders("Drafts").Items
There are some tricks you can try.
.DoEvents, .GetInspector and as a last resort .Display.
Sub Drafts_Send()
Dim objDrafts As Items
Dim objDraft As Object
Dim i As Long
Set objDrafts = Session.GetDefaultFolder(olFolderDrafts).Items
For i = objDrafts.Count To 1 Step -1
If objDrafts.Item(i).Class = olMail Then
Set objDraft = objDrafts.Item(i)
With objDraft
If .Subject = "Please Thank You" Then
' this has some .Display behaviour, without displaying
.GetInspector
'.Display ' as a last resort
objDrafts.Item(i).Subject = "Please & Thank You"
DoEvents
' if in Draft folder reading pane should be off
.Save
End If
End With
Set objDraft = Nothing
End If
Next
Set objDrafts = Nothing
End Sub
I have VBA code whose main functions are:
Load a form
Allow a user to choose a stock email response
Open a word document with the full response text
Create a reply using the text
Search the email and create a collection of strings containing corporate file numbers
Add the file numbers to an Excel list
Send the response
Now I want to save one copy of the sent item in a Windows folder, for each file number. I’ve been trying to wait until the item is sent and moved to Sent Items. The problem is that after calling the send method, the mailitem doesn’t send or move to Sent Items until after the code finishes so I end up in an infinite loop.
All the options I found involve using a class module and WithEvents. That would work if I wanted to copy every sent item to the folder. I can’t think of any criteria that would differentiate the emails created by this macro from normal emails. I could go into the Excel list of files, but that would bog everybody’s machine down on every send.
Is there a way to just have the email send find out when it has been sent and moved to sent items? My code to send, wait for it to go to sent items, and to save the emails is below. Note I have two global variables: cReply (Outlook.MailItem – the reply) and fNums (Collection – the file numbers).
I'm coding in Outlook 2016, but hope to move the module to Outlook 2010 at work.
Sub Send()
Dim badChar As String
badChar = "\/:*?™""® <>|.&##_+`©~;-+=^$!,'" & Chr(34)
Dim x As Integer
Dim fName As String
Dim inSentItems As Boolean
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFldr As Outlook.MAPIFolder
Dim cSent As Outlook.MailItem
Dim sentMoment As Date
fName = cReply.Subject
For x = 1 To Len(badChar)
fName = Replace(fName, Mid(badChar, x, 1), "-")
Next x
Set olApp = GetObject(, "Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderSentMail)
inSentItems = True
x = olFldr.Items.Count
sentMoment = Now
cReply.Send
Do While olFldr.Items.Count <> x + 1
If Now - sentMoment > TimeValue("0:00:10") Then
inSentItems = False
Exit Do
End If
DoEvents
Loop
If inSentItems Then
Set cSent = olFldr.Items(olFldr.Items.Count)
For x = 1 To fNums.Count
cSent.SaveAs sentFldrPth & fNums.Item(x) & " - " & fName & ".msg", olMSG
Next x
'cSent.Delete
End If
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
End Sub
You could use SaveSentMessageFolder to save to another folder.
https://msdn.microsoft.com/en-us/library/office/ff868473.aspx
Monitor this other folder with ItemAdd code. You could move the mail to the Sent Items folder once done.
I have a sorting script executed in all comming mails.
The account is shared by 5 computers and all of them have the script running.
For some reason the script works fine several times but there is a moment that it stops working, i set a debug point in the script and aparentlly the script is not being executed. The rule dont show any error.
Sub sortingP8(Item As Outlook.MailItem)
Dim olkAtt As Outlook.Attachment
'Check each attachment
Dim totalSize As Double
Dim containsZip As Boolean
Dim wrongExt As Boolean
totalSize = 0
containsZip = False
wrongExt = False
somethingWrong = False
Set ns = Application.GetNamespace("MAPI")
Set nonIngFolder = ns.Folders("Pqweeeq#asdasd.es").Folders("Non-ingestible Items")
Set ingFolder = ns.Folders("Pqweeeq#asdasd.es").Folders("Ingestible Items")
Set zipFolder = ns.Folders("Pqweeeq#asdasd.es").Folders("ZIP files")
For Each olkAtt In Item.Attachments
Dim extension As String
extension = Right(LCase(olkAtt.FileName), 4)
'If the attachment's file name ends with .zip
totalSize = totalSize + olkAtt.Size
If extension <> ".ppt" And extension <> ".doc" And extension <> ".pdf" And extension <> ".jpg" And extension <> ".zip" Then
wrongExt = True
End If
If extension = ".zip" Then
containsZip = True
End If
Next
If (wrongExt = True Or totalSize > 10000000) Then
Item.Move nonIngFolder
somethingWrong = True
End If
If (containsZip = True And somethingWrong = False) Then
Item.Move zipFolder
somethingWrong = True
End If
If (somethingWrong = False) Then
Item.Move ingFolder
End If
Set olkAtt = Nothing
End Sub
Any idea how this is happening in every computer?
Did you have a chance to check out the Trust Center settings in Outlook? Is Outlook macro allowed to run?
Try to run the VBA sub against the incoming email message manually and debug the code in the step-by-step manner going through each line of code and see what happens there.
Finally, you may find the Getting Started with VBA in Outlook 2010 article helpful.
If the computer is left alone, the session disconnect timeout could be the culprit.
I was trying to implement a script to move a specific mail to a new folder - no tough stuff.
It is scripted in Outlook 2013 and implemented as a rule on incoming mails. The code:
Public Sub MoveToFolder(Item As Outlook.MailItem)
'' ... variable definitions ...
Set oloUtlook = CreateObject("Outlook.Application")
Set ns = oloUtlook.GetNamespace("MAPI")
Set itm = ns.GetDefaultFolder(olFolderInbox)
Set foldd = ns.Folders.GetFirst.Folders
For x = 1 To foldd.Count
If foldd.Item(x).Name = "Inbox" Then
Set fold = foldd.Item(x).Folders
For i = 1 To fold.Count
If fold.Item(i).Name = "Reports" Then
If fold.Item(i).Folders.GetFirst.Name <> Format(Date, "yyyy-mm") Then
fold.Item(i).Folders.Add (Format(Date, "yyyy-mm"))
End If
Set newfold = fold.Item(i).Folders.GetFirst
MsgBox newfold.Name
Item.Copy (newFold)
''Item.Move (newfold)
End If
Next i
End If
Next x
End Sub
The message comes to folder Inbox, I'd like to move it to:
Reports -> 2013-XX depending on the current month.
MessageBox shows the correct folder name. but the message is copied to folder "Inbox" as a duplicate.
What am I doing wrong? Cheers.
I'm not sure why your method isn't working. When I run it in 2010, it gets the right folder. I'm not sure why you think the current date folder will always be the first folder, but I've never used GetFirst, so maybe I just don't understand it. Here's a more straightforward way to test and create a folder and it may work for you.
Public Sub MoveToFldr(Item As MailItem)
Dim oFldr As Folder
Dim fReports As Folder
Set fReports = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Reports")
On Error Resume Next
Set oFldr = fReports.Folders(Format(Date, "yyyy-mm"))
On Error GoTo 0
If oFldr Is Nothing Then
Set oFldr = fReports.Folders.Add(Format(Date, "yyyy-mm"))
End If
Item.Move oFldr
End Sub
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