I'm currently struggling with the following issue:
I'm trying to improve some process at work, which involves organizing large amounts of project emails (.msg), stored in a folder. Files need to be renamed from 'Message.msg' to 'DateSent-from Sender-Message.msg'.
Now the renaming is easy to do with an excel macro, but I'm really struggling to get the data I need from the .msg.
Is there any way for excel to read some information from a .msg file? Everything I tried so far has failed. I'm interested in the Sender and Date Sent.
Thanks a lot for any suggestions!
here is some starting code
Option Explicit
Sub getMsgData()
' add reference to microsoft outlook object library
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim mailDoc As Outlook.MailItem
Dim i As Long
i = 1
Dim nam As Variant
For Each nam In Array("test.msg", "test2.msg")
Set mailDoc = olApp.Session.OpenSharedItem(ActiveWorkbook.Path & "\" & nam)
Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
mailDoc.Close False
i = i + 1
Next nam
olApp.Quit
Set mailDoc = Nothing
Set olApp = Nothing
End Sub
Related
I am trying to access the Folder from Outlook in VBA,some folder I am able to access but few folder are not. Although I am able to read 1 subfolder from the below code but when i am trying to change folder it is giving error.
This the code with which I am trying to access :
Public Sub ReadOutlookEmails()
Dim out_app As Outlook.Application
Dim get_name As Outlook.Namespace
Dim get_folder As Outlook.MAPIFolder
Dim oAccount As Object
Dim store_add As Object
Dim monthKeyValuePair As New Scripting.Dictionary
Dim email_list As New mscorlib.ArrayList
Dim date_List As New mscorlib.ArrayList
For Each c In Worksheets(ActiveSheet.Name).Range("D8:AH8")
date_List.Add c
'MsgBox c
Next c
Set out_app = New Outlook.Application
Set get_name = out_app.GetNamespace("MAPI")
For Each oAccount In out_app.Session.Accounts
If oAccount.SmtpAddress = "chhabranaveen#gmail.com" Then
Set store_add = oAccount.DeliveryStore
'MsgBox store_add.GetDefaultFolder(olFolderInbox).Folders("New Joinees")
'Set get_folder = store_add.GetDefaultFolder(olFolderInbox).Folders("On Bench Training")
Set get_folder = store_add.GetDefaultFolder(olFolderInbox)
Set get_folder = get_folder.Folders("On Bench Training")
Please help me here what I am doing wrong.
The error is MAPI_E_NOT_FOUND, which means the folder with the given name does not exist.
Make sure the folder named "On Bench Training" is really a subfolder of the Inbox.
Instead of getting the folder by its name you may try iterating over all subfolders and checking their name. So, basically instead of the following line:
Set get_folder = get_folder.Folders("On Bench Training")
You may iterate over all subfolder:
For Each uFolder In get_folder.Folders
If uFolder.Name = "On Bench Training" Then
MsgBox "Found!"
End If
Next uFolder
Is there a method in VBA to achieve the same effect of right-clicking on a folder in the folder pane and selecting 'Sort Subfolders A to Z'?
As a comparison, the code below from Microsoft.com sorts Items in a folder; however, it does not appear that the .Sort method used in this code is available for the Folders object like it is for the Items object.
Sub SortByDueDate()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItem As Outlook.TaskItem
Dim myItems As Outlook.Items
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
Set myItems = myFolder.Items
myItems.Sort "[DueDate]", False
For Each myItem In myItems
MsgBox myItem.Subject & "-- " & myItem.DueDate
Next myItem
End Sub
Additionally, it does not appear that there are any methods available for moving folders in the tree.
Is more extensive code required to replicate the native 'Sort Subfolders A to Z' action with VBA?
Can this be achieved with PropertyAssessor and, if so, what is the proper syntax for setting the PR_SORT_POSITION property? For example, the code below results in an error, as commented in the code.
Sub Example()
Dim myProp As String
Dim myValue As Variant
Dim oFolder As Folder
Set oFolder = Application.Session.GetDefaultFolder(olFolderInbox)
myProp = "http://schemas.microsoft.com/mapi/proptag/0x30200102"
myValue = "FD7F"
oFolder.PropertyAssessor.SetProperty myProp, myValue 'Run-time error '438': Object doesn't support this property or method
End Sub
The Outlook object model doesn't provide any property or method to sort folders. You may find the NavigationPane object helpful. See Customizing the Navigation Pane for more information.
You can sort the folders in the Outlook UI by explicitly setting the PR_SORT_POSITION property on each subfolder - see Get folder list ordered as displayed
I posted my code here because this was high in Google results and all other threads were closed
https://answers.microsoft.com/en-us/outlook_com/forum/all/sorting-outlook-subfolders-z-a/9aef727c-510c-49e0-869d-4234373b71d7
https://answers.microsoft.com/en-us/outlook_com/forum/all/sort-order-of-subfolders/a3b55181-4f5a-43c1-82b3-94eb68a8407b
I've made custom VBA code to sort subfolders Z-A - it will load the folder order [unfortunately you still need to order it A-Z within outlook] and then reverse it so it is Z-A
I needed to quickly adjust a tonne of folders and couldn't find any code anywhere, so I quickly made the below to help patch the issue.
I didn't have the time to write lots of detail about how it works.
Known issues with the code:
It doesn't always sort the first folder. No idea why.
It doesn't seem to like it when you're looking at the list of subfolders - minimise it then run the code
This code is used to reverse the sorting of subfolders under Inbox, you'll need to adjust as required.
Sub sortZA()
Dim email_name: email_name = "email#emails.com" 'write the name of the mailbox as it appears in outlook
Dim objMainFolder As Outlook.Folder
Dim Folders As Outlook.Folders
Dim Folderx As Outlook.Folder
Dim sort_order, sort_order_b, arr
Set arr = CreateObject("System.Collections.ArrayList")
Set arr_sorted = CreateObject("System.Collections.ArrayList")
dim found_folder: found_folder=0
Set Folders = Application.ActiveExplorer.Session.Folders
For Each Folderx In Folders
If LCase(Folderx.Name) = LCase(email_name) Then
Set objMainFolder = Folderx.Folders("Inbox") 'adjust as required. Add more folders via .folders("name")
found_folder=1
End If
Next
if found_folder =0 then
msgbox "the email folder with the name '" & email_name & "' was not found"
exit sub
end if
Dim reloadFolder As Outlook.Folder
Dim propertyAccessor As Outlook.propertyAccessor
For Each Folderx In objMainFolder.Folders
' if there is an error, then there might not be any order data. Try reordering them manually. Also make sure loading the email as the main profile instead of as an additional mailbox.
'On Error Resume Next
Set propertyAccessor = Folderx.propertyAccessor
sort_order = propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30200102"))
arr.Add Folderx.Name & "##~~##" & sort_order
arr_sorted.Add Folderx.Name & "##~~##" & sort_order
Next
arr.Sort 'keep A-Z (the original list from outlook isn't in A-Z order)
arr_sorted.Sort 'make A-Z
arr_sorted.Reverse 'make Z-A
Dim t, a, b, i, t2, a2, b2
i = 0
For Each arr_folder In arr
t = Split(arr_folder, "##~~##")
a = t(0) 'which folder name?
b = t(1) 'what is the original order? [should already be A-Z]
Set Folders = Application.ActiveExplorer.Session.Folders
For Each Folderx In Folders
'On Error Resume Next
If LCase(Folderx.Name) = LCase(email_name) Then
Set reloadFolder = Folderx.Folders("Inbox").Folders(a)
End If
Next
t2 = Split(arr_sorted(i), "##~~##")
a2 = t2(0) 'which folder name?
b2 = t2(1) 'what is the reversed order?
Set propertyAccessor = reloadFolder.propertyAccessor
propertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30200102", propertyAccessor.StringToBinary(b2)
i = i + 1
Next
End Sub
Additional Notes: I did try experimenting with applying ordering data manually. I couldn't get it to work properly. All the binary converting code wasn't producing the correct values, and I ended up using HEX(). Here is an example of what I was doing:
Dim custom_order As Long
custom_order = 15
For Each arr_folder In arr
'the array only contains a list of folder names.. we need to load the folder in outlook to process it again. The below line of code loads the main email inbox, then the subfolder from the array [different from the above code]
Set reloadFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders(arr_folder)
Set propertyAccessor = reloadFolder.propertyAccessor
hexval = Hex(custom_order)
propertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30200102", propertyAccessor.StringToBinary(hexval)
custom_order = custom_order + 1
Next
End Sub
I've had an Outlook 2016 VBA macro running for a year to check emails arriving in my inbox. Today, following installation of Windows 10 updates, I get a type mismatch error when this macro runs. The error line is the Set olNs = Application.GetNamespace("MAPI") line below:
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim olRecip As Recipient
Dim dt As String
Dim strFile_Path As String
dt = Format(CStr(Now), "yyyy_mmm_dd_hh_mm")
strFile_Path = "d:\temp\parking.log"
Open strFile_Path For Append As #1
Write #1, dt & " " & "Application_Startup() triggered"
Close #1
Set olNs = Application.GetNamespace("MAPI")
Set olRecip = olNs.CreateRecipient("me#gmail.com")
Set Inbox = olNs.Folders("me#gmail.com").Folders("Inbox")
Set Items = Inbox.Items
End Sub
Any idea how I can fix this?
First of all, you need to make sure the COM references are set correctly.
You may try to run the code without setting a local variable:
Private Sub Application_Startup()
MsgBox "Welcome, " & Application.GetNamespace("MAPI").CurrentUser
Application.ActiveExplorer.WindowState = olMaximized
End Sub
I just ran into this issue (COM add-ins were fine) and as stated, removing the explicit declaration seems to fix the issue (you can also Dim the Namespace as an Object instead of Outlook.Namespace).
As a quick reference for anyone else I used the following code to bypass the issue:
With Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = .GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = .GetDefaultFolder(olFolderJunk)
End With
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 created several MS Access databases that connect to my company's SQL server (MSSQL), perform calculations, then export the results in the form of email. These are set up to run through the windows task scheduler at a certain time of the day. Before you ask, I do not have access to the SQL server so I cannot create any stored procedures or do anything other than read. These run on a desktop computer under my desk which is on 100% of the time (other than a weekly reboot).
The issue I am having is with using VBA in MS Access to actually send the emails. All of the SQL and excel formatting work as intended, but I ran into the issue of Access closing Outlook before the email leaves my outbox. Attempts to make Access wait or sleep until emails have been sent are causing the program to indefinetly hang. I would greatly appreciate any help you can provide on how to resolve this issue.
Thank you and please see below. My best guess at this point is that the sleep or wait methods I have used get stuck when two seperate Access Databases attempt to use them at the same time. I suspect this because when I run each process independently to debug, they are able to run without issues.
Windows Task Scheduler:
6:30AM (Task 1)(Run Time 2mins)- Access opens an internet page, pulls data, formats in excel, and saves to a network drive where a different program (not written by me) scoops up the data at 7:00 and uploads to SQL server. This is the first scheduled task and rarely has issues.
7:30AM (Task 2)(Run Time 5 mins) - Access connects to SQL, runs queries, exports results to excel file (no email).
7:35AM (Task 3)(Run Time 1.5hours) - Access connects to SQL, runs lots of very big queries, then exports file to excel and attempts to send emails. This one has issues where file is created and when I attempt to email, it either sits in outbox until I open outlook or file is created and it has trouble sending the email.
8:00AM (Task 4)(Run Time 3 mins) - Access connects to SQL, runs queries, sends emails. Usually has no issues but occasionally emails get stuck in Outbox.
8:00AM (Task 5)(Run Time 30 mins) - Access connects to SQL, runs queries, gets files from task 2, sends emails.
For all tasks, these are the settings:
Run only when user is signed on.
Run with highest privileges.
Action - Start a program (.bat)
The .bat files have this general format:
#echo on
cscript SCRIPT_NAME.vbs
The .vbs files have this general format:
Dim oAccessApp
Set oAccessApp = createObject("Access.Application")
oAccessApp.OpenCurrentDataBase("C:\PATHNAME.accdb")
oAccessApp.Visible = True
oAccessApp.Run "VBA_FUNCTION_NAME", "PARAMETERS"
oAccessApp.Application.Quit
Set oAccessApp = nothing
Outlook VBA Module
I suspect the issue I am having is related to the way I am sending the emails because the files output correctly even if the emails are not sent. Also, the code is able to run correctly when I test each .bat independently. Below please find my code that I use to send the emails.
Option Compare Database
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Function sendToOutlook(sWhNo As String)
Dim s As String
Dim n As Integer
n = FreeFile()
Open "C:\PATHNAME\logfile.txt" For Output As #n
s = "Hello, world!"
Print #n, s
Dim XL As Excel.Application
Dim XlBook As Excel.Workbook
Dim fileNameLocation As String
Dim olApp As Outlook.Application
Dim olInsp As Outlook.Inspector
Dim olMail As Outlook.MailItem
Dim olAttachments As Outlook.Attachments
Dim subjectStr As String
Dim sWhString As String
Select Case sWhNo
Case "CASE_STATEMENTS_HERE"
subjectStr = "CITY_NAME"
sWhString = subjectStr
'more cases
End Select
Print #n, subjectStr
Print #n, sWhString
toStr = "email1#example.com;email2#example.com, etc"
bccStr = ""
subjectStr = subjectStr & "_" & exportTime & " REPORT_NAME"
fileLocation = "C:\TASK2_FILEPATH"
XlFileFormatStr = ".xlsx"
Print #n, toStr
Print #n, ccStr
Print #n, subjectStr
Print #n, fileLocation
Print #n, XlFileFormatStr
Dim qryRange1 As Excel.Range
Dim sFileLocation As String
Dim sFileName As String
Dim sFullFileNameLoc As String
Dim sMonthNum As String
Dim sDayNum As String
sFileLocation = "C:\CURRENT_TASK_PATHNAME\"
sDayNum = Day(Date)
If sDayNum - 10 < 0 Then sDayNum = "0" & Day(Date)
sMonthNum = Month(Date)
If sMonthNum - 10 < 0 Then sMonthNum = "0" & Month(Date)
sFileName = sWhNo & "_REPORT_NAME_" & Year(Date) & sMonthNum & sDayNum & ".xlsx"
Print #n, sFileName
sFullFileNameLoc = sFileLocation & sFileName
Print #n, sFullFineNAmeLoc
Set XL = CreateObject("Excel.Application")
Set XlBook = XL.Workbooks.Open(sFullFileNameLoc)
XL.DisplayAlerts = False
XL.AskToUpdateLinks = False
XL.EnableEvents = False
XL.Visible = True
Set qryRange1 = XlBook.Sheets("SHEET_NAME").Range(XlBook.Sheets("SHEET_NAME").Cells(1, 1).Address(), XlBook.Sheets("SHEET_NAME").Cells(11, 14).Address())
On Error Resume Next
Set olApp = New Outlook.Application
If Err.Number = 429 Then
Print #n, "429!!!"
Debug.Print "429!!!"
Set olApp = GetObject(, "Outlook.Application")
Set olInsp = olApp.ActiveInspector
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachments = olMail.Attachments
GoTo LBL_CLOSE
End If
Set olInsp = olApp.ActiveInspector
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachments = olMail.Attachments
olMail.SentOnBehalfOfName = "group_mailbox#example.com"
Print #n, "NO 429"
olAttachments.Add ("C:\TASK2_FILEPATH\" & exportFileNameGlobal_FINAL)
LBL_CLOSE:
Set qryRange1 = XlBook.Sheets("SHEET_NAME").Range(XlBook.Sheets("SHEET_NAME").Cells(1, 1).Address(), XlBook.Sheets("SHEET_NAME").Cells(11, 14).Address())
With olMail
.To = toStr
.CC = ccStr
.BCC = bccStr
.Subject = subjectStr
.HTMLBody = "Please find attached blah blah blah " & sWhString & vbCrLf & RangetoHTML(qryRange1, XL)
.Display
End With
Dim olAppNS As Outlook.Namespace
Dim olFolder As Outlook.Folder
With olMail
.Send
End With
XlBook.Close
XL.Quit
Set XlBook = Nothing
Set XL = Nothing
olApp.Quit
Set olApp = Nothing
Set olInsp = Nothing
Set olMail = Nothing
Set olAttachments = Nothing
Dim olApp1 As Outlook.Application
Set olApp1 = New Outlook.Application
Dim mySyncObject As Outlook.SyncObject
Dim sync As Outlook.SyncObject
Set olAppNS = olApp1.GetNamespace("MAPI")
Set olFolder1 = olAppNS.GetDefaultFolder(olFolderOutbox)
Set mySyncObjects = olAppNS.SyncObjects
For i = 1 To mySyncObjects.Count
Set sync = mySyncObjects(i)
sync.Start
Next
Do While olFolder1.Items.Count > 0
Sleep 10000
Loop
Close #n
Sleep 60000
olApp1.Quit
Set olApp1 = Nothing
Please advise what I am doing wrong that is causing access to hang and how I should fix. I greatly appreciate any help that you can provide. Thank you.
If you are using Exchange, you can turn cached mode off - message will be sent immediately. Otherwise you have no choice but to start the sync (SyncObject.Start) and wait for the SyncObject.SyncEnd event to fire.
Because of the nature of Office Applications, I'd guess that you're sleeping its only thread and it literally cannot attempt to send the mail while you're either eating up or throwing away all its CPU time. Instead of polling the mailbox and trying to manually wait for the mailitems to send, try using that SyncObject you've already made to register an event handler.
Here's an idea of what I mean. The following is a new class module:
Dim WithEvents mySync As Outlook.SyncObject
Dim myApp As Outlook.Application
Sub Close_After(ByRef toClose As Outlook.Application, ByRef newSync As Outlook.SyncObject)
Set myApp = toClose
Set mySync = newSync
mySync.Start
End Sub
Private Sub mySync_SyncEnd()
myApp.Quit
End Sub
This wraps around a SyncObject and gives it an event handler that will close the current application.
And in your calling code, do something like:
Dim syncClose As New SyncHandler ' Scope to module so we don't lose the reference
Function sendToOutlook(sWhNo As String)
' ...
Dim olApp1 As Outlook.Application
Set olApp1 = New Outlook.Application
' ...
Set olAppNS = olApp1.GetNamespace("MAPI")
Set olFolder1 = olAppNS.GetDefaultFolder(olFolderOutbox)
Set mySyncObjects = olAppNS.SyncObjects
syncClose.Close_After olApp1, (mySyncObjects(1))
End Function
This passes the first SyncObject into your class, which starts the sync and, when the sync completes, closes the passed-in Outlook.Application. If (for some reason) you have more than one SyncObject you want to wait for you'll have to restructure to ensure all have already finished before closing the app. The concept will be the same, though - build wrappers that register event handlers (or one big wrapper class that handles the events of many individual SyncObjects), but add a check that all the syncs must complete before the Application closes.
Although you indicate you want to use outlook, I found it was easier to not rely on Outlook for sending email, so I've used CDO for a very similar application. See email using Access and VBA without MAPI