I'm really having trouble finding any answers for this problem. I have an Excel macro that filters a sheet (it's a basic order form), copies and emails a range using an Outlook object. The file worked for several weeks and ran quickly.
Now all of the sudden whenever the macro is run the Excel portion of filtering and copying works fine but when it gets to the email code Outlook locks up, and I get a popup from Excel saying it's waiting for Outlook to complete an OLE action. I end up having to kill the Outlook process. I've tried early and late bindings.
Sub EmailOrder()
Dim answer As Integer
Dim lastRow As String
Dim filteredRow
Dim emailApp As Outlook.Application
Dim emailItem As Outlook.MailItem
Dim exportRange As Range
Dim currentTime As String
Dim currentUserEmailAddress As String
answer = MsgBox("Click OK to send your order to the supply team", vbOKCancel)
If answer = vbOK Then
Worksheets("Sheet1").Activate
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
currentTable = "$A$1:$E$" & lastRow
'Filter out blanks
Range(currentTable).AutoFilter Field:=5, Criteria1:="<>"
Set exportRange = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set exportRange = Selection.SpecialCells(xlCellTypeVisible)
'Setup outlook objects and mail
Set emailApp = New Outlook.Application
Set emailItem = emailApp.CreateItem(olMailItem)
Set outSession = emailItem.Session.CurrentUser
currentUserEmailAddress = outSession.AddressEntry.GetExchangeUser().PrimarySmtpAddress
currentTime = Now
'Write email
With emailItem
.To = "redacted#gmail.com"
.CC = currentUserEmailAddress
.Subject = "Local Inventory Order " & currentTime
.HTMLBody = RangetoHTML(exportRange)
.Send
End With
'Close objects
Set emailApp = Nothing
Set emailItem = Nothing
MsgBox ("The order has been emailed to the supply team.")
End If
End Sub
The RangetoHTML function is from Ron de Bruin's website. Any help is appreciated.
EDIT: failed to mention that there have been other users of the sheet who reported it working for several weeks then stopping.
Related
what I want to do is copy a range of cells and paste them into an outlook template that also has a message in the body. The code that I have is
Sub SendEmail_Class_Name()
Dim r As Range
Set r = Range("A1:AA3")
r.Copy
Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)
EmailItem.To = "Name#gmail.com"
EmailItem.CC = "Name1#gmail.com; Name2#gmail.com;" & _
"Name3#gmail.com; Name4#gmail.com"
EmailItem.Subject = "Test Email From Excel VBA"
EmailItem.HTMLBody = "Hey,<p>" & "Seeing if this Macro will send an Email<p>" & _
"Thanks,<p>"
Source = ThisWorkbook.FullName
EmailItem.Attachments.Add Source
EmailItem.Display
Dim wordDoc As Word.Document
Set wordDoc = EmailItem.GetInspector.WordEditor
wordDoc.Range.PasteAndFormat wdChartPicture
End Sub
As of now the code will run and pull up the template with the To, CC, and Subject correct but the message in the body will not appear only the picture of the cells and I tried putting the picture before the code for the message and only the message will appear and not the picture. So, my question is how do I order my code so that both the message and picture appear in the body of the email.
Thanks
I want to code a VBA such that the mail can be sent only if the user fills in details in rows. If not, an alert showing "Cannot send update. Fill the details completely" should pop up on the users screen.
Eg: The user has to fil Columns "A to J" and "M". If not they cannot send mail and pop up should ask them to enter it.
I have the following code as below,
Sub MAIL()
Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)
EmailItem.To = "abc#gmail.com"
EmailItem.Subject = " "
EmailItem.HTMLBody = ""
Source = ThisWorkbook.FullName
EmailItem.Attachments.Add Source
EmailItem.Send
End Sub
Please help me provide alerts to users. I am completely new to this.
Please, use the next function. It will check if at least a cell is filled in all columns of the range ("A:J, M:M"). In such a case it returns True. Otherwise, it send a relevant message and returns false, stopping the mail sending:
Function checkIfOK() As Boolean
Dim rng As Range, ar As Range, i As Long
Set rng = Range("A:J,M:M")
For Each ar In rng.Areas
For i = 1 To ar.Columns.count
If WorksheetFunction.CountA(ar.Columns(i)) > 1 Then
MsgBox "Column " & Split(ar.Columns(i).cells(1).Address, "$")(1) & " is empty..."
Exit Function
End If
Next i
Next ar
checkIfOK = True
End Function
You have to use it in your code in the next way:
Sub MAIL()
If Not checkIfOK Then Exit Sub 'it stop the code here if the function returns False
Dim EmailApp As Outlook.Application, Source As String
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)
EmailItem.To = "abc#gmail.com"
EmailItem.Subject = " "
EmailItem.HtmlBody = ""
Source = ThisWorkbook.fullName
EmailItem.Attachments.Add Source
EmailItem.Send
End Sub
The function has been built on the above mentioned assumption. I asked you in my comment "How this to be appreciated?" and you did not answer anything...
I'm trying to get all the cells from my Excel worksheet in column 1.
My code throws an error.
"object required"
Public Sub emailList()
'Setting up the Excel variables.
Dim olApp As Object
Dim olMailItm As Object
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
'Create the Outlook application and the empty email.
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
'Using the email, add multiple recipients, using a list of addresses in column A.
With olMailItm
SDest = ""
For iCounter = 1 To WorksheetFunction.CountA(Workbooks("Book1.xls").Sheets(1).Columns(1))
If SDest = "" Then
SDest = Range.Cells(iCounter, 1).Value
Else
SDest = SDest & ";" & Range.Cells(iCounter, 1).Value
End If
Next iCounter
'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
.BCC = SDest
.Subject = "FYI"
.Body = ActiveSheet.TextBoxes(1).Text
.Send
End With
'Clean up the Outlook application.
Set olMailItm = Nothing
Set olApp = Nothing
End Sub
How do I get a worksheet object?
I tried
Workbooks("Book1.xls").Sheet1.Columns(1)
but this also throws an error.
I'm running the code in Outlook and have an open Excel window.
You will need to add a reference to the Excel object library, which is done in the VBA editor, under Tools / Add References. Just having Excel open isn't enough.
I'm creating an Outlook email from Excel (Office 2013). I want to paste a range of cells (C3:S52) into the email as a picture.
Below is the code I have so far. Where am I going wrong?
Sub Button193_Click()
'
' Button193_Click Macro
'
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("C3:S52").Select
Selection.Copy
End Sub
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E55")
Set rngSubject = .Range("E56")
Set rngBody = .Range("E57")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
Sub Button235_Click()
'
' Button235_Click Macro
'
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A1:M27").Select
Selection.Copy
End Sub
Sub RunThemAll()
Application.Run "Button193_Click"
Application.Run "CreateMail"
End Sub
Here's a worked example, tested in Office 2010:
'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
'To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
'To paste as a table
'wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
Result:
In the code above I used early binding to have access to autocomplete; to use this code you need to set references to the Microsoft Outlook and Microsoft Word object libraries: Tools > References... > set checkmarks like this:
Alternatively, you can forget about the references and use late binding, declaring all the Outlook and Word objects As Object instead of As Outlook.Application and As Word.Document etc.
Apparently you're having trouble implementing the above; the range pastes as a table rather than a picture in your email message. I have no explanation for why that would happen.
An alternative is then to paste as an image in Excel, and then cut and paste that image into your e-mail:
'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy
'Paste as picture in sheet and cut immediately
Dim p As Picture
Set p = ActiveSheet.Pictures.Paste
p.Cut
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
'Paste picture
wordDoc.Range.Paste
As pointed out by WizzleWuzzle, there is also the option of using PasteSpecial instead of PasteAndFormat or Paste...
wordDoc.Range.PasteSpecial , , , , wdPasteBitmap
... but for some reason, the resulting image doesn't render as well. See how the lower table is kind of blurry:
I am providing an alternative solution to the above problem as Outlook.MailItem.GetInspector.WordEditor does not work in some organizational environments.
For security purposes, the HTMLBody, HTMLEditor, Body and WordEditor properties all are subject to address-information security prompts because the body of a message often contains the sender's or other people's e-mail addresses. And, if Group Policy does not permit then these prompts do not come on-screen. In simple words, as a developer, you are bound to change your code, because neither registry changes can be made nor group policy can be modified.
Hence, if your code suddenly stopped working after migrating to Office 365 or for any other reasons, please refer to the code below. Comments have been added for easy understanding and implementation.
If you have administrative rights then try the registry changes given at below link:
https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
However, as developer, I recommend a code that's rather compatible with all versions of Excel instead of making system changes because system changes will be required on each end user's machine as well.
Code Compatible: Excel 2003, Excel 2007, Excel 2010, Excel 2013, Excel 2016, Office 365
Option Explicit
Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)
Dim rngToPicture As Range
Dim outlookApp As Object
Dim Outmail As Object
Dim strTempFilePath As String
Dim strTempFileName As String
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
With Outmail
.To = strTo
.Subject = strSubject
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<img src='cid:DashboardFile.png' style='border:0'>"
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub
I am trying to copy an entire sheet into an email body and the sheet is already filtered and hides rows. I want to copy only the visible rows into the email. I thought my code would do that but when the people reply to the emails, the entire sheet (both hidden and unhidden) appears in the email. Any ideas?
Sub Send_Range_Or_Whole_Worksheet_with_MailEnvelope()
'Working in Excel 2002-2013
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
.Application.DisplayAlerts = False
End With
'Fill in the Worksheet/range you want to mail
'Note: if you use one cell it will send the whole worksheet
Set Sendrng = Worksheets("Test").Range("A1").SpecialCells(xlCellTypeVisible)
'Remember the activesheet
Set AWorksheet = ActiveSheet
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
' Set the optional introduction field thats adds
' some header text to the email body.
.Introduction = "Test"
With .Item
.To = "test#email.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.Send
End With
End With
'select the original ActiveCell
rng.Select
End With
This was essentially taken from this Example 2 of Ron de Bruin, with some code from another example.
The code below seems to work.
You will have to fill it in with Ranges selection/activation and other details as needed.
EDIT The final step is sending the email (as per an added request of the OP). DoEvents added thanks to an answer to Excel VBA: Sent Outlook email does not include pasted Range
Sub SendEmail()
Dim OutlookApp As Object
'Dim OutlookApp As Outlook.Application
Dim MItem As Object
'Dim MItem As Outlook.MailItem
'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
'Set OutlookApp = New Outlook.Application
Dim Sendrng As Range
Set Sendrng = Worksheets("Test").Range("A1").SpecialCells(xlCellTypeVisible)
Sendrng.Copy
'Create Mail Item
Set MItem = OutlookApp.CreateItem(0)
'Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = "test#email.com"
.Subject = "Test"
.CC = ""
.BCC = ""
'.Body = "a"
.Display
End With
SendKeys "^({v})", True
DoEvents
With MItem
.Send
End With
Set OutlookApp = Nothing
Set MItem = Nothing
End Sub
Since you did not state it is mandatory to use VBA (at least when this answer was first posted), you might:
Go to Home -> Find & Select -> Go To Special -> Visible cells only. Then copy and paste into your email. That worked for me.