I am using below code to send multiple emails through outlook, this code is working fine when I use Excel 2007 and Outlook 2007 however when I tried to run same code in Excel 2013 and Outlook 2013 it is throwing an error "Runtime Error 424: Object not Defined" in the below code:
Set Doc = olMail.GetInspector.WordEditor
Can somebody please check below coding and let me know what do I need to change if I want to use same macro in 2013 version?
Sub Msmail()
Dim otlApp As Object
Dim olMail As Object
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
Set mainWB = ActiveWorkbook
Worksheets("Mail").Select
ActiveSheet.Calculate
Total_Site = Range("Total_Site")
For Site_Count = 1 To Total_Site
Application.StatusBar = False
ActiveSheet.Calculate
Range("Site_Count") = Site_Count
ActiveSheet.Calculate
If Range("Send_Email") = "Y" Then
Set mainWB = ActiveWorkbook
Set olMail = otlApp.CreateItem(olMailItem)
Set Doc = olMail.GetInspector.WordEditor '<~ ERROR 424 HERE
SendID = mainWB.Sheets("Mail").Range("To_List").Value
CCID = mainWB.Sheets("Mail").Range("Cc_List").Value
Subject = mainWB.Sheets("Mail").Range("Subject_Line").Value
Body = mainWB.Sheets("Summary").Range("Mail_Body").Value
AttachFile = mainWB.Sheets("Mail").Range("StrPath").Value
StrPath = ActiveSheet.Range("StrPath").Value
With olMail
.To = SendID
If CCID <> 0 Then
.CC = CCID
End If
.Subject = Subject
mainWB.Sheets("Summary").Range("Mail_Body").Copy
Set WrdRng = Doc.Range
.Display
WrdRng.Paste
'StrPath = Range("StrPath").Value
StrFile = Range("StrFile").Value & "*.*"
StrFile = Range("StrFile").Value
.Attachments.Add StrPath & "\" & StrFile
.Send
End With
End If
Next Site_Count
End Sub
OK - so there appear to be quite a lot of issues with the current code; you have duplication of code and non-dimensioned variables. I have tried to condense the code down, added direct references and this will hopefully make it more readable and (should maybe) work, but it's untested... I don't have the ranges set out in relevant sheets and no data to test it
Sub msMail()
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olMail As Object
Dim Total_Site As Range, Doc As Variant, WrdRng As Range
Dim StrPath As String, StrFile As String, Site_Count As Long
Dim wbMain As Workbook: Set wbMain = ThisWorkbook
Dim wsMail As Worksheet: Set wsMail = wbMain.Worksheets("Mail")
Dim wsSumm As Worksheet: Set wsSumm = wbMain.Worksheets("Summary")
With wsMail
.Calculate ' Not sure why this is included...
Set Total_Site = Range("Total_Site")
For Site_Count = 1 To Total_Site.Count
''Application.StatusBar = False
Range("Site_Count") = Site_Count
If Range("Send_Email") = "Y" Then
Set olMail = olApp.CreateItem(olMailItem)
Set Doc = olMail.GetInspector.WordEditor
If Not Doc Is Nothing Then
With olMail
.To = wsMail.Range("To_List")
.CC = IIf(wsMail.Range("Cc_List") <> 0, wsMail.Range("Cc_List"), "")
.Subject = wsMail.Range("Subject_Line")
wsSumm.Range("Mail_Body").Copy
Set WrdRng = Doc.Range
.Display
WrdRng.Paste
StrPath = wsMail.Range("StrPath")
StrFile = wsMail.Range("StrFile")
.Attachments.Add StrPath & "\" & StrFile
' .Send
End With
End If
End If
Next Site_Count
End With
End Sub
Related
I want to take a reference number in an email to highlight and replace with a direct link to web page.
The current code will place the new hyperlink at the start of the email instead of the selected areas (currently wddoc.Range(0 , 0)).
If I use Selection it says the variable is undefined by user.
Sub AddHyperlink()
Dim olEmail As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim oRng As Object
Dim strLink As String
Dim strLinkText As String
Dim OutApp As Object
Dim OutMail As Object
Dim strText As String
On Error Resume Next
'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, so cancel
If Err <> 0 Then
MsgBox "Outlook is not running so nothing can be selected!"
GoTo lbl_Exit
End If
On Error GoTo 0
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)
With OutMail
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
strText = wdDoc.Application.Selection.Range.Text
End With
strLink = "http://website.com/#" & strText & "" ' the link address
strLinkText = "" & strText & "" ' the link display text
On Error Resume Next
Set olEmail = ActiveInspector.CurrentItem
With olEmail
.BodyFormat = olFormatHTML
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0) '!!!Cannot find something that replaces range with current selection!!!!
oRng.Collapse 0
Set oLink = wdDoc.Hyperlinks.Add(Anchor:=oRng, _
Address:=strLink, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=strLinkText)
Set oRng = oLink.Range
oRng.Collapse 0
.Display
End With
lbl_Exit:
Exit Sub
End Sub
When I have a new email open in MS Outlook, I'll have a keyboard shortcut setup to run the code in VBA within Outlook.
Outlook vba while working with ActiveInspector, try the following.
Option Explicit
Public Sub Example()
Dim wdDoc As Word.Document
Dim rngSel As Word.selection
If Application.ActiveInspector.EditorType = olEditorWord Then
Set wdDoc = Application.ActiveInspector.WordEditor ' use WordEditor
Set rngSel = wdDoc.Windows(1).selection ' Current selection
wdDoc.Hyperlinks.Add rngSel.Range, _
Address:="U:\plot.log", TextToDisplay:="Here is the link"
End If
Set wdDoc = Nothing
End Sub
I'm trying to create a macro in MS-Word VBA to take the contents of a MS-Word table (with a bookmarked name), iterate through the rows of the table and create tasks in MS-Outlook (1 row=1 task).
I have Googled and think I will need to try and mix together the following two scripts I have found:
Script 1 - (For making calendar entries - not wanted, but iteration through rows - wanted)
Sub AddAppntmnt()
'Adds a list of events contained in a three column Word table
'with a header row, to Outlook Calendar
Dim olApp As Object
Dim olItem As Object
Dim oTable As Table
Dim i As Long
Dim bStarted As Boolean
Dim strStartDate As Range
Dim strEndDate As Range
Dim strSubject As Range
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oTable = ActiveDocument.Tables(1)
'Ignore the first (header) row of the table
For i = 2 To oTable.Rows.Count
Set strStartDate = oTable.Cell(i, 1).Range
strStartDate.End = strStartDate.End - 1
Set strEndDate = oTable.Cell(i, 2).Range
strEndDate.End = strEndDate.End - 1
Set strSubject = oTable.Cell(i, 3).Range
strSubject.End = strSubject.End - 1
Set olItem = olApp.CreateItem(1)
olItem.Start = strStartDate
olItem.End = strEndDate
olItem.ReminderSet = False
olItem.AllDayEvent = True
olItem.Subject = strSubject
olItem.Categories = "Events"
olItem.BusyStatus = 0
olItem.Save
Next i
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
Set oTable = Nothing
End Sub
Script 2 - has the actual task creation bit I think I need although this one is about setting task to remind user to do something in 2 weeks or something:
Sub AddOutlookTask()
Dim olApp As Object
Dim olItem As Object
Dim bStarted As Boolean
Dim fName As String
Dim flName As String
On Error Resume Next
If ActiveDocument.Saved = False Then
ActiveDocument.Save
If Err.Number = 4198 Then
MsgBox "Process ending - document not saved!"
GoTo UserCancelled:
End If
End If
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set olItem = olApp.CreateItem(3) 'Task Item
fName = ActiveDocument.name
flName = ActiveDocument.FullName
olItem.Subject = "Follow up " & fName
olItem.Body = "If no reply to" & vbCr & _
flName & vbCr & "further action required"
olItem.StartDate = Date + 10 '10 days from today
olItem.DueDate = Date + 14 '14 days from today
olItem.Importance = 2 'High
olItem.Categories = InputBox("Category?", "Categories")
olItem.Save
UserCancelled:
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
End Sub
How do I reference a particular table in MS-Word in code? I have bookmarked it so it has a "name" if that helps!
With Davids help (above) I have got the following solution to my problem. I post here for others if they come across a similar issue:
Sub CreateTasks()
'
' CreateTasks Macro
'
'
'
'Exports the contents of the ACtoins table to MS-Outlook Tasks
' Set Variables
Dim olApp As Object
Dim olItem As Object
Dim oTable As Table
Dim i As Long
Dim strSubject As Range
Dim strDueDate As Range
Dim strBody As Range
Dim strSummary As String
Dim bStarted As Boolean
'Dim strPupil As WdBookmark
Dim strPerson As Range
'Link to Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
'Set table variable to the bookmarked table
Set oTable = ActiveDocument.Bookmarks("Actions").Range.Tables(1)
'Ignore the first (header) row of the table
For i = 3 To oTable.Rows.Count
Set strSubject = oTable.Cell(i, 3).Range
strSubject.End = strSubject.End - 1
Set strBody = oTable.Cell(i, 4).Range
strBody.End = strBody.End - 1
Set strDueDate = oTable.Cell(i, 5).Range
strDueDate.End = strDueDate.End - 1
'next line not working below
'Set strPupil = WdBookmark.Name
'Create the task
Set olItem = olApp.CreateItem(3) 'Task Item
strSummary = Left(strSubject, 30)
olItem.Subject = "CYPP Action for" & " " & strBody & "-" & strSummary & "..."
olItem.Body = strBody & vbNewLine & olItem.Body & vbNewLine & strSubject
olItem.DueDate = strDueDate & olItem.DueDate
olItem.Categories = "CYPP"
olItem.Save
Next i
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
Set oTable = Nothing
End Sub
I will be adding to this to deal with empty rows but I am pleased with the functionality so far. The DateDue is not working yet but I think that is a formatting issue.
Thanks again David,
Richard.
I'm using the basic VBA code to send an email with a copy of my spreadsheet on a daily basis. The email subject is always the same.
I want these emails to appear in Outlook as the same conversation, so that they are nested/threaded when using Conversation view. However, these emails always come up as a new conversation.
How can I set a property in the OutMail variable below similar to .subject etc to create my own ConversationID / ConversationIndex that is always identical so that emails appear nested?
VBA code:
Dim Source As Range 'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:AQ45").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
TempFilePath = "C:\temp\"
TempFileName = "MyReport " & Format(Now, "yyyy-mm-dd hh-mm-ss")
FileExtStr = ".xlsx": FileFormatNum = 51
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
End With
With Dest
With OutMail
.to = "xyz#zyx.com"
.CC = ""
.BCC = ""
.Subject = "Subject Report 1"
.HTMLBody = RangetoHTML(Range("A1:AQ45"))
.Attachments.Add Dest.FullName
.Send
End With
End With
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
With Dest
On Error GoTo 0
.Close savechanges:=False
End With
This is the Outlook code that you can port over to Excel, using the method I suggest in the comments above.
Sub test()
Dim m As MailItem
Dim newMail As MailItem
Dim NS As NameSpace
Dim convo As Conversation
Dim cItem
Dim entry As String 'known conversationID property
Set NS = Application.GetNamespace("MAPI")
'Use the EntryID of a known item
'## MODIFY THIS BASED ON YOUR ENTRYID PROPERTY!! ##
entry = "0000000019EF3F5F49714748915AA379833C20460700D6CCDE850A3B9D41A5B930CCE1E12030000337DBD42F00003C7DFC9FAAF8254DACC71DEEEC1DF0A30003ADA9AF2D0000"
'Get a handle on this item:
Set m = NS.GetItemFromID(entry)
'Get a handle on the existing conversation
Set convo = m.GetConversation
'Get a handle on the conversation's root item:
Set cItem = convo.GetRootItems(1)
'Create your new email as a reply thereto:
Set newMail = cItem.Reply
'Modify the new mail item as needed:
With newMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Subject Report 1"
.HTMLBody = RangeToHTML(Range("A1:AQ45"))
.Attachments.Add Dest.FullName
.Display
'.Send
End With
End Sub
I have a little script that converts an email into a Task in my outlook.
My main frustration is that it won't preserve the html format, and deals with embedded images as attachments. I was wondering if anyone could help. I know it is possible as I've copied the body of an email directly across to the body of a task manually and it is preserved fine.
Sub ConvertSelectedMailtoTask()
Dim objApp As Outlook.Application
Dim objTask As Outlook.TaskItem
Dim objMail As Outlook.MailItem
Set objTask = Application.CreateItem(olTaskItem)
Set objApp = Application
If TypeName(objApp.ActiveWindow) = "Explorer" Then
For Each objMail In Application.ActiveExplorer.Selection
If Left(objMail.Subject, 3) = "RE:" Or Left(objMail.Subject, 3) = "FW:" Then
subj = Right(objMail.Subject, Len(objMail.Subject) - 4)
Else
subj = objMail.Subject
End If
With objTask
.Subject = subj
.Importance = objMail.Importance
.StartDate = objMail.ReceivedTime
.Body = objMail.Body
.DueDate = Date + 3
If objMail.Attachments.Count > 0 Then
CopyAttachments objMail, objTask
End If
.ReminderSet = True
.ReminderTime = Date + 2.5
.Sensitivity = olPrivate
.Save
End With
Next
ElseIf TypeName(objApp.ActiveWindow) = "Inspector" Then
Set objMail = objApp.ActiveInspector.CurrentItem
If Left(objMail.Subject, 3) = "RE:" Or Left(objMail.Subject, 3) = "FW:" Then
subj = Right(objMail.Subject, Len(objMail.Subject) - 4)
Else
subj = objMail.Subject
End If
With objTask
.Subject = subj
.Importance = objMail.Importance
.StartDate = objMail.ReceivedTime
.Body = objMail.Body
.DueDate = Date + 3
If objMail.Attachments.Count > 0 Then
CopyAttachments objMail, objTask
End If
.ReminderSet = True
.ReminderTime = Date + 2.5
.Sensitivity = olPrivate
.Save
End With
End If
Set objTask = Nothing
Set objMail = Nothing
Set objApp = Nothing
End Sub
And here is the script for the attachments
Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub
Update:
I found a bit of code that uses a word document to preserve the formatting:
Sub CopyFullBody(sourceItem As Object, targetItem As Object)
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim objDoc2 As Word.Document
Dim objSel2 As Word.Selection
On Error Resume Next
' get a Word.Selection from the source item
Set objDoc = sourceItem.GetInspector.WordEditor
If Not objDoc Is Nothing Then
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory
objSel.Copy
Set objDoc2 = targetItem.GetInspector.WordEditor
If Not objDoc2 Is Nothing Then
Set objSel2 = objDoc2.Windows(1).Selection
objSel2.PasteAndFormat wdPasteDefault
Else
MsgBox "Could not get Word.Document for " & _
targetItem.Subject
End If
Else
MsgBox "Could not get Word.Document for " & _
sourceItem.Subject
End If
Set objDoc = Nothing
Set objSel = Nothing
Set objDoc2 = Nothing
Set objSel2 = Nothing
End Sub
This doesn't seem like it would be the only solution hence updating my own post instead of answering my question as this seems a bit long winded (using another application just to give me formatting, when I can copy and paste text manually just fine all in Outlook). If anyone has any other thoughts on this/defining attachment types please carry on answering!
in the line
.Body = objMail.Body
you only ask fot the non-formatted Body. Try instead:
.Body = objMail.htmlBody
and something completely different: I just put reminders onto the emails themselves, so I have no need to create extra Tasks at all...
Keep in mind that Outlook tasks, appointments and tasks work with RTF, not HTML. hence TaskItem, ContactItem and AppointmentItem objects only expose the RtfBody property, but not HTMLBody (like MailItem does).
You will need to either convert HTML to RTF (you can try the Word Object Model for that) or use Redemption (I am its author): unlike Outlook Object Model, it exposes the RDOTaskItem.HTMLBody property and dynamically converts HTML to the native (for tasks) RTF when that property is set.
I am writing macro that will set a signature after choosing the From field or for example clicking reply. My problem is that I don't know how to get the From field value. I know how to set this field.
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Function GetSignature(Mailbox As String) As String
Dim Signature As String
Dim SigStringPL As String
Dim SigStringUK As String
SigStringPL = Environ("appdata") & _
"\Microsoft\Signatures\Poland.htm"
SigStringUK = Environ("appdata") & _
"\Microsoft\Signatures\United Kingdom.htm"
If Mailbox = "poland#poland.pl" Then
If Dir(SigStringPL) <> "" Then
GetSignature = GetBoiler(SigStringPL)
Else
GetSignature = ""
End If
Else
If Dir(SigStringUK) <> "" Then
GetSignature = GetBoiler(SigStringUK)
Else
GetSignature = ""
End If
End If
End Function
Sub Mail_Outlook_With_Signature_Plain()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "content"
Signature = GetSignature("erni#erni.pl")
MsgBox (OutMail.SentOnBehalfOfName)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.subject = "This is the Subject line"
.HTMLBody = strbody & "<br><br>" & Signature
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Regards,
erni
SenderName is the field name for 'From' field.
From is SentOnBehalfOfName. In normal use, it is empty until the item has been sent.
Do not choose the From manually.
Sub replySentOnBehalf()
Dim objMsg As mailitem
Set objMsg = ActiveInspector.currentItem.reply
objMsg.SentOnBehalfOfName = "someone#somewhere.com"
' Now that objMsg.SentOnBehalfOfName is available run your code
objMsg.Display
Set objMsg = Nothing
End Sub