I created a program for myself and a few of my colleagues. One of the functions of my program runs a macro that grabs data from the Excel sheet and opens a populated email in Outlook.
In order to run this macro you need to add the Object Library "Microsoft Outlook 16.0 Object Library".
Is there any way to do this automatically, so that all of my colleagues can run this macro?
Here's the code for my email generator.
' -- Drafts an email in Outlook -- '
Public Sub emailDraft()
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim masterWS As Worksheet
Dim masterWB As Workbook
Dim counter As Long
Set objOutlook = Outlook.Application
Set objMail = objOutlook.CreateItem(olMailItem)
Set masterWB = Workbooks("Master.xlsm")
Set masterWS = masterWB.Worksheets("MASTER SHEET")
objMail.To = masterWS.Range("F6").Value
objMail.CC = "test#email.com"
objMail.Subject = masterWS.Range("F7").Value
objMail.Body = masterWS.Range("F8").Value
objMail.Display
End Sub
Thank you #Warcupine for your insight.
I was able to solve this by using late binding. My updated code is below.
' -- Drafts an email in Outlook -- '
Public Sub emailDraft()
Dim objOutlook As Object 'Outlook.Application
Dim objMail As Object 'Outlook.MailItem
Dim masterWS As Worksheet
Dim masterWB As Workbook
Dim counter As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(olMailItem)
'objOutlook.CreateItem (olMailItem)
Set wb = ThisWorkbook
Set wsMAST = wb.Worksheets("MASTER")
objMail.To = wsMAST.Range("K2").Value
objMail.CC = "test#email.com"
objMail.Subject = wsMAST.Range("k3").Value
objMail.Body = wsMAST.Range("k4").Value
objMail.Display
End Sub
Related
This code is to iterate an Outlook folder to extract the table in each email to paste to Excel.
After executing the paste line Outlook will crash and auto restart.
The line of code that causes the loop to stop is objExcelWorksheet.Paste.
If I execute without the loop the table pastes. When in a loop it can't run the second time and crashes after pasting the first table in Microsoft Excel.
Sub ExportTablesinEmailtoExcel()
Dim objMail As Outlook.MailItem
Dim objWordDocument As Word.Document
Dim objTable As Word.Table
Dim lTableCount As Long
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Dim i As Long
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim Item As Object
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders("some_email#some.com") ' folders of your current account
Set objFolder = objFolder.Folders("Buyer advise (IO)")
Set Item = objFolder.Items
'Create a new excel workbook
Set objExcelApp = CreateObject("Excel.Application")
Set objExcelWorkbook = objExcelApp.Workbooks.Add
objExcelApp.Visible = True
For Each Item In objFolder.Items
If TypeOf Item Is Outlook.MailItem Then
' ... do stuff here ...
Item.UnRead = False
'Get the table(s) in the selected email
Set objMail = Outlook.Application.ActiveExplorer.Selection.Item(1)
Set objWordDocument = objMail.GetInspector.WordEditor
lTableCount = objWordDocument.Tables.Count - 1
'If there is only one table
'Just copy it into the first worksheet
Set objTable = objWordDocument.Tables(1)
objTable.Range.Copy
Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
objExcelWorksheet.Paste
objExcelWorksheet.Columns.AutoFit
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Interacting with Excel requires extreme care.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
'
' If desperate declare as variant
Sub ExportTablesinEmailtoExcel_WithCare()
' Interacting with Excel requires extreme care
Dim objMail As Outlook.MailItem
Dim objWordDocument As Word.Document
Dim objTable As Word.Table
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.mapiFolder
Dim Item As Object
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.folders("some_email#some.com") ' folders of your current account
Set objFolder = objFolder.folders("Buyer advise (IO)")
'Create a new excel instance
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Visible = True
For Each Item In objFolder.items
If TypeOf Item Is Outlook.MailItem Then
Item.UnRead = False
'Get a table from the item in this iteration of the loop
Set objMail = Item
Set objWordDocument = objMail.GetInspector.WordEditor
'If there is only one table
If objWordDocument.Tables.count = 1 Then
'Just copy it into the first worksheet
Set objTable = objWordDocument.Tables(1)
objTable.Range.Copy
'Create a new excel workbook
Set objExcelWorkbook = objExcelApp.Workbooks.Add
Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
objExcelWorksheet.Paste
objExcelWorksheet.Columns.AutoFit
Debug.Print Item.ConversationTopic
End If
' Release memory. Apparently not reused in next iteration.
Set objMail = Nothing
Set objWordDocument = Nothing
Set objTable = Nothing
Set objExcelWorkbook = Nothing
Set objExcelWorksheet = Nothing
End If
Next
Debug.Print "Done."
End Sub
I have found the code below from here https://stackoverflow.com/a/49207287/4539709
Option Explicit
Public Sub Example()
' add ref - tool -> references - > Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim Email As Outlook.MailItem
Set Email = olApp.CreateItem(0)
' add ref - tool -> references - > Microsoft Word XX.X Object Library
Dim wdDoc As Word.Document '<=========
Set wdDoc = Email.GetInspector.WordEditor
Dim Sht As Excel.Worksheet
Set Sht = ThisWorkbook.Worksheets("Sheet1")
Dim rng As Range
Set rng = Sht.Range("A4:H16").SpecialCells(xlCellTypeVisible)
rng.Copy
With Email
.To = Sht.Range("C1")
.Subject = Sht.Range("B1")
.Display
wdDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
End With
End Sub
I have come across an issue with the code in that after you send an email the rows remain selected as per attached. Is there anyway to clear this
Add the following line at the end Application.CutCopyMode = False
With Email
.To = Sht.Range("C1")
.Subject = Sht.Range("B1")
.Display
wdDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
End With
Application.CutCopyMode = False '<---
End Sub
I'm fairly new to programming. Could you, please, help me identify the problem and possibly solve it. The macro below is supposed to extract tables from an e-mail folder. The first two parts work pretty well: I can open up the Excel export file and choose the email folder. However, export to the file fails as a target spreadsheet appears not to be recognized as an object. Thank you in advance.
Sub FolderEmptyCellTable()
Dim Mails As Outlook.MailItem
Dim NSP As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim i As Integer
Dim WordDoc, Selection, XL, Tabl, WL, WB As Object
'Open up an Excel file
Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set WB = XL.Workbooks.Open("C:\User\Desktop\Task\File.xlsx")
'Choose the export folder
Set NSP = Application.GetNamespace("MAPI")
Set Folder = NSP.PickFolder
'Run through e-mails collecting tables
For Each Mails In Folder.Items
Set WordDoc = Mails.GetInspector.WordEditor
If WordDoc.Tables.Count >= 1 Then
For i = 1 To WordDoc.Tables.Count
Set Tabl = WordDoc.Tables(i)
Tabl.Range.Copy
'Insert*emphasized text* each table to a separate sheet
Set WL = WB.Sheets(i)
'Here is where the error 424 occurs: Object required
**WL.Range("a1").End(xlDown).Offset(1, 0).Select**
Selection.Parent.PasteSpecial Format:="Text", Link:=False, _
DisplayAsIcon:=False
Next i
Else: MsgBox "No tables found"
Exit Sub
End If
Next Mails
End Sub
Declare like this:
Dim WordDoc As Object
Dim Selection As Object
Dim XL As Object
Dim Tabl As Object
Dim WL As Worksheet
Dim WB As Workbook
Thus, you will make sure that they are objects indeed. In your code, only WB is object, the others are of type Variant.
Thanks to a colleague of mine, the issue has been resolved.
Sub FolderEmptyCellTable()
Dim Mails As Outlook.MailItem
Dim NSP As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim XL As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim WL As Object
Dim WordDoc As Object
Dim Tabl As Object
Dim i As Integer
Dim Selection As Object
Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set WB = Workbooks.Open("C:\User\Desktop\Task\File.xlsx")
Set NSP = Application.GetNamespace("MAPI")
Set Folder = NSP.PickFolder
Dim lastRow As Integer
For Each Mails In Folder.Items
Set WordDoc = Mails.GetInspector.WordEditor
If WordDoc.Tables.Count >= 1 Then
For i = 1 To WordDoc.Tables.Count
Set Tabl = WordDoc.Tables(i)
Tabl.Range.Copy
Set WS = WB.Worksheets(i)
lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1
WS.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
Next i
Else
MsgBox "No tables found"
GoTo LabelNext
End If
LabelNext:
Next Mails
End Sub
Because I am unable to set a rule in Outlook to run a VBA script, I tried to create a workaround.
When a certain daily email comes in with an attachment, I want to download the excel attachment and open an excel workbook and run a vba script in that excel to update information, update charts, save the file, and send the file as an email.
I am having trouble with the integration. Ideally I would like to have Outlook automatically download an excel attachment when an email comes from a specific sender with a specific subject line, and then run excel vba script.
What I am currently doing is running a rule in Outlook that files the email in a sub-folder and having excel vba connect to outlook, find the email, download the file, and run code from excel, all when an email with "Test" in the subject line shows up in the default inbox.
I know this is long winded, but there has to be a better solution! Please help Here is my code so far:
Outlook:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim xlApp As Object
Dim oxl As Excel.Application
Dim owb As Excel.Workbook
Dim wsheet As Excel.Worksheet
Dim asd As Object
Dim ExApp As Excel.Application
Dim ExWbk As Workbook
Dim myDestFolder As Outlook.Folder
If TypeName(item) = "MailItem" Then
Set Msg = item
If Msg.Subject = "Test" Then
Set ExApp = New Excel.Application
Set ExWbk = ExApp.Workbooks.Open("excel file i want to open and run script")
ExApp.Visible = False
ExWbk.Application.Run "Module1.fromnew"
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myInbox.Folders("Test")
**Msg.Move myDestFolder**
'Not working
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Excel:
Sub fromnew()
Dim myd, myy As String
Dim newfile As Workbook
Dim prod As Workbook
Call Test
'Goes into Outlook and finds the email in an Outlook subfolder and downloads 'the excel attachment. I want to remove this and have outlook automatically 'download the attachment so I don't have to call test()
myd = Format(Date, "yyyymmdd")
myy = Format(Date, "yyyy")
Set prod = ActiveWorkbook
Set newfile = Workbooks.Open("xyz\ds\" & myy & "\blahblahblah" & myd)
newfile.Sheets(1).Range("A1:AA7000").Copy Destination:=prod.Sheets("Data").Range("A1")
prod.Sheets("Data").Range("A2") = 1
newfile.Close
prod.Activate
prod.SaveAs ("here is a file name")
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#xyz.com"
.CC = ""
.BCC = ""
.Subject = "here are your things"
.Body = "Do you like beer?"
.Attachments.Add ("here is a file name")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
prod.Close
End Sub
you did not say why you are unable to set a rule in Outlook
you may have to change a key in windows registry to enable the execution of vba in a rule
do a web search for "EnableUnsafeClientMailRules" and read info from any microsoft.com page that comes up in the search
here is a link that is current today, but may change in future
it refers to outlook2013 and outlook2016
https://support.microsoft.com/en-us/help/3191893/how-to-control-the-rule-actions-to-start-an-application-or-run-a-macro
I am trying to create a Outlook VBA code to save attachments from a particular mail to a folder,then copy paste the data from the attachment in another excel.And then mail the 2nd excel to some ids.
I have created a rule 1st to move the incoming auto mail to a particular mail folder,Then save its attachment to the desktop folder.After saving the attachment the data gets copied to the 2nd excel. The code is like this
Public Sub ExportFile(MyMail As MailItem)
Dim outNS As Outlook.NameSpace
Dim outFolder As Outlook.MAPIFolder
Dim outNewMail As Outlook.MailItem
Dim strDir As String
Set outNS = GetNamespace("MAPI")
Set outFolder = outNS.GetDefaultFolder(olFolderInbox).Folders("Network Critical Report")
Set outNewMail = outFolder.Items.GetLast
strDir = "C:\Users\soumyajitd\Desktop\December\Network Critical Report\"
If outNewMail.Attachments.count = 0 Then GoTo Err
outNewMail.Attachments(1).SaveAsFile strDir & "Network_Critical_Report.csv"
Dim xlApp As Excel.Application
Dim wbTarget As Excel.Workbook 'workbook where the data is to be pasted
Dim wsTarget As Excel.Worksheet
Dim wbThis As Excel.Workbook 'workbook from where the data is to copied
Dim wsThis As Excel.Worksheet
Dim strName As String 'name of the source sheet/ target workbook
Set xlApp = New Excel.Application
xlApp.DisplayAlerts = False
'xlApp.Workbooks.Open strDir & "Network_Critical_Report.csv"
'xlApp.Workbooks.Open strDir & "Test.xlsx"
Set wbThis = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\December\Network Critical Report\Network_Critical_Report.csv")
Set wsThis = wbThis.Worksheets("Network_Critical_Report")
Set wbTarget = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\December\Network Critical Report\Test.xlsx")
Set wsTarget = wbTarget.Worksheets("Raw_Data")
'select cell A1 on the target book
'clear existing values form target book
wsTarget.UsedRange.ClearContents
'activate the source book
wbThis.Activate
xlApp.CutCopyMode = False
'copy the range from source book
wsThis.UsedRange.Copy
'paste the data on the target book
wsTarget.Range("A1").PasteSpecial Paste:=xlPasteValues
'save the target book
wbTarget.Save
'close the workbook
wbTarget.Close
wbThis.Close
xlApp.CutCopyMode = False
Kill ("C:\Users\soumyajitd\Desktop\December\Network Critical Report\Network_Critical_Report.csv")
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing
Set xlApp = Nothing
Set outNewMail = Nothing
Set outFolder = Nothing
Set outNS = Nothing
Err:
Set outFolder = Nothing
Set OuNewMail = Nothing
Set outNS = Nothing
End Sub
The second code is to send a new email with "Test.xlsx" as attachment.It is like this :
Sub SendNew(Item As Outlook.MailItem)
Dim objMsg As MailItem
Dim ToRecipient As Variant
Dim ccRecipient As Variant
Dim Subject As String
Dim Body As String
Dim FilePathtoAdd As String
Set objMsg = Application.CreateItem(olMailItem)
objMsg.ToRecipients.Add "alias#mail.com"
objMsg.CCRecipients.Add "xx#yy.com"
objMsg.Subject = "Subject"
objMsg.Body = "Body"
If FilePathtoAdd <> "" Then
objMsg.Attachments.Add "C:\Users\soumyajitd\Desktop\December\Network Critical Report\Test.xlsx"
End If
objMsg.Send
I have very little experience in VBA coding.I have taken all these codes from different forums and have modified them to suit my need.
Now there are 3 problems.
The attachment which is getting saved is not from the last mail,it is taking the data from the 2nd last mail.
I am trying to run the script by adding rule for receiving mail,but it is showing only the 2 different scripts. I tried many ways but couldnot combine both of them.
The 2nd script is not working,giving an error "Runtime error '-2147467259(8004005)':
"Outlook doesnot recongnize 1 or more names"
For your 1st Problem, see THIS
For your 2nd Problem
To combine, either join both the scripts in one SUB or call the other from the first.
For your 3rd Problem
There is no property called .ToRecipients and .CCRecipients. Change it to objMsg.To = "alias#mail.com" and objMsg.CC = "xx#yy.com" respectively.
Also your FilePathtoAdd = "" so your if condition is not met. Either delete that IF Condition or change your code to this
FilePathtoAdd = "C:\Users\soumyajitd\Desktop\December\Network Critical Report\Test.xlsx"
With objMsg
.To = "alias#mail.com"
.CC = "xx#yy.com"
.Subject = "Subject"
.Body = "Body"
.Attachments.Add FilePathtoAdd
End With