I have a database, just with names and e-mail addresses and I need to create individual e-mails with a specific fixed text, that is in a specific range of my excel and save it in a specific folder of my hard drive.
However, I'm having problems with the body text.
Here it is the code:
Sub test()
Dim Sendrng As Range
Dim outlookApp As Outlook.Application
Dim outlookMail As Outlook.MailItem
Dim i As Integer
For i = 2 To ActiveSheet.Cells(5, 2).Value + 1
Set Sendrng = ActiveSheet.Range("B12:K29")
Set outlookApp = New Outlook.Application
Set outlookMail = outlookApp.CreateItem(olMailItem)
With outlookMail
.To = ActiveSheet.Cells(7, 2).Value
.Subject = ActiveSheet.Cells(8, 2).Value
'.HTMLBody = Sendrng
.Save
End With
i = i + 1
ActiveSheet.Cells(4, 2) = i
Set outlookMail = Nothing
Set outlookApp = Nothing
Next i
'I want to start every time in position 2
ActiveSheet.Cells(4, 2) = 2
End Sub
Can you explain to me where is missing? I'm getting the following error: Run-time Error 13: Type mismatch
Thanks,
Henrique
You need to use the Text property of the Range class instead of Value:
Sub test()
Dim Sendrng As Range
Dim outlookApp As Outlook.Application
Dim outlookMail As Outlook.MailItem
Dim i As Integer
For i = 2 To ActiveSheet.Cells(5, 2).Value + 1
Set Sendrng = ActiveSheet.Range("B12:K29")
Set outlookApp = New Outlook.Application
Set outlookMail = outlookApp.CreateItem(olMailItem)
With outlookMail
.To = ActiveSheet.Cells(7, 2).Text
.Subject = ActiveSheet.Cells(8, 2).Text
.Save
End With
i = i + 1
ActiveSheet.Cells(4, 2) = i
Set outlookMail = Nothing
Set outlookApp = Nothing
Next i
'I want to start every time in position 2
ActiveSheet.Cells(4, 2) = 2
End Sub
Related
I have developed a template with which I can automate invoice reminders by outputting emails. Currently the code loops through the list outputting an email for each individual row (= each individual invoice). I would like to update the code so that it skips outfiltered rows in the excel doc to make it more efficient and easier in use.
My code is as follows:
Sub Send_email_fromtemplate()
Dim edress As String
Dim cc1, cc2, cc3 As String
Dim group As String
Dim number As String
Dim outlookapp As Object
Dim outlookmailitem As Object
Dim r As Long
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
r = 3
Do While Sheet1.Cells(r, 1) <> ""
Set outlookapp = CreateObject("Outlook.Application")
'call your template
Set outlookmailitem = outlookapp.CreateItemFromTemplate([location])
outlookmailitem.Display
edress = Sheet1.Cells(r, 7)
cc1 = Sheet1.Cells(r, 8)
cc2 = Sheet1.Cells(r, 9)
cc3 = Sheet1.Cells(r, 10)
group = Sheet1.Cells(r, 4)
number = Sheet1.Cells(r, 3).Value
With outlookmailitem
.To = edress
.cc = cc1 & ";" & cc2 & ";" & cc3
.bcc = ""
.Subject = "First invoice reminder " & group
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:="{{Number}}")
oRng.Text = number
Exit Do
Loop
End With
Set xInspect = outlookmailitem.GetInspector
.Display
'.send
End With
'clear your email address
edress = ""
r = r + 1
Loop
'clear your fields
Set outlookapp = Nothing
Set outlookmailitem = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub
I've tried to solve the problem using a Range function and ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible), but as the template will be filled with a variable number of rows (each time I send reminders) this is causing troubles, as the range differs each time.
Please, try the next updated code. As I said in my above comment, it is able to calculate the last row on A:A, then create a range from visible rows of the filtered area and iterate between its rows:
Sub Send_email_fromtemplate()
Dim edress As String, cc1 As String, cc2 As String, cc3 As String
Dim group As String, number As String
Dim outlookapp As Object, outlookmailitem As Object, olInsp As Object
Dim wdDoc As Object, xInspect As Object
Dim oRng As Object, lastR As Long, rngVis As Range, r As Range
lastR = Sheet1.Range("A" & Sheet1.rows.count).End(xlUp).row 'last row on A:A
On Error Resume Next 'this is necessary in case of no any filtered visible cell
Set rngVis = Sheet1.Range("A3:J" & lastR).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngVis Is Nothing Then MsgBox "No visible filtered values in the necessary range...": Exit Sub
Set outlookapp = CreateObject("Outlook.Application") 'you should set it only ones, outside of the iteration...
For Each r In rngVis.rows 'iterate between the discontinuous (visible cells) rows
'call your template
Set outlookmailitem = outlookapp.CreateItemFromTemplate([Location])
outlookmailitem.Display
edress = r.cells(1, 7) 'extract the necessary values from the iterated row
cc1 = r.cells(1, 8)
cc2 = r.cells(1, 9)
cc3 = r.cells(1, 10)
group = r.cells(1, 4)
number = r.cells(1, 3).Value
With outlookmailitem
.To = edress
.cc = cc1 & ";" & cc2 & ";" & cc3
.BCC = ""
.Subject = "First invoice reminder " & group
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:="{{Number}}")
oRng.Text = number
Exit Do
Loop
End With
Set xInspect = outlookmailitem.GetInspector
.Display
'.send
End With
'clear your email address
edress = ""
Next r
'clear memory of used objects:
Set outlookapp = Nothing: Set outlookmailitem = Nothing
Set wdDoc = Nothing: Set oRng = Nothing
End Sub
Please, send some feedback after testing it.
I'm trying to import all mails received and sent the past year.
For the received mails works, but the code stops when importing the sent mails. Specifically for the OutlookMail.To property. It stops when it gets to an accepted invitation for a meeting that I have sent.
Is there a way to bypass all the accepted invitations that I have sent and only get the emails?
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder1 As MAPIFolder
Dim Folder2 As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder1 = OutlookNamespace.GetDefaultFolder(olFolderInbox)
Set Folder2 = OutlookNamespace.GetDefaultFolder(olFolderSentMail)
i = 1
For Each OutlookMail In Folder1.Items
If OutlookMail.ReceivedTime >= Range("H5").Value And OutlookMail.ReceivedTime <= Range("I5").Value Then
Range("C4").Offset(i, 0).Value = OutlookMail.Subject
Range("A4").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("B4").Offset(i, 0).Value = OutlookMail.SenderName
i = i + 1
End If
j = 1
Next OutlookMail
For Each OutlookMail In Folder2.Items
If OutlookMail.ReceivedTime >= Range("H5").Value And OutlookMail.ReceivedTime <= Range("I5").Value Then
Range("f4").Offset(j, 0).Value = OutlookMail.Subject
Range("d4").Offset(j, 0).Value = OutlookMail.ReceivedTime
Range("E4").Offset(j, 0).Value = OutlookMail.To
j = j + 1
End If
Next OutlookMail
Set Folder1 = Nothing
Set Folder2 = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
Something like this (refactoring a bit)
Sub GetFromOutlook()
Dim olApp As Outlook.Application
Dim olNS As Namespace, ws As Worksheet
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set ws = ActiveSheet
ListFolder olNS.GetDefaultFolder(olFolderInbox), ws.Range("C4")
ListFolder olNS.GetDefaultFolder(olFolderSentMail), ws.Range("F4")
End Sub
'List info for all mail items in `fldr`, starting at `rng`
Sub ListFolder(fldr As MAPIFolder, rng As Range)
Dim itm As Variant, i As Long
For Each itm In fldr.Items
If TypeOf itm Is MailItem Then 'is this a mail item?
'faster to write whole row in one shot
rng.Cells(1).Offset(i).Resize(1, 3).Value = _
Array(itm.Subject, itm.ReceivedTime, itm.to)
i = i + 1 'increment row
End If 'is a mail object
Next itm
End Sub
I would like to import mail data from Outlook.
I have no problem to import classic fields such as: From, Subject ... etc. I cannot find how to import my "User-defined field".
The User-defined field is named "DemandQTY" and contains only numbers.
I get my data from a shared mailbox.
Sub GetFromOutlook()
Dim OutApp As Outlook.Application
Dim OutNS As Namespace
Dim Folder As MAPIFolder
Dim OutMail As Variant
Dim i As Integer
Dim objOwner As Outlook.Recipient
Dim FileName As String
Dim MI As Outlook.MailItem
Dim Item As Object
Dim Atmt As Attachment
Set OutNS = GetNamespace("MAPI")
Set OutApp = New Outlook.Application
Set objOwner = OutNS.CreateRecipient("emailadress")
objOwner.Resolve
If objOwner.Resolved Then
Set Folder = OutNS.GetSharedDefaultFolder(objOwner, olFolderInbox)
i=2
For Each OutMail In Folder.Items
Sheets(2).Cells(i, 1) = OutMail.EntryID
' (etc....)
Sheets(2).Cells(i, 32) = OutMail.ReminderTime
i = i + 1
Next OutMail
MsgBox "Importation Terminée"
Sheets(2).Select
Sheets(2).Cells(1, 1).Select
Set OutApp = Nothing
Set OutNS = Nothing
Set Folder = Nothing
End If
End Sub
I tried different methods found on internet, but nothing worked.
We can do this by first testing if the property exists. If it doesn't and you try to work with it, it will throw an error. Afterwards we can access the value if the property is found.
For Each OutMail In Folder.Items
Sheets(2).Cells(i, 1) = OutMail.EntryID
(etc....)
Sheets(2).Cells(i, 32) = OutMail.ReminderTime
If Not(OutMail.UserProperties.Find("DemandQTY", True) Is Nothing) Then
Sheets(2).Cells(i, 33) = OutMail.UserProperties("DemandQTY").Value
End If
i = i + 1
Next OutMail
I am attempting to loop through a column (n=96) in my worksheet, when it comes across a value <10 I would like the macro to open outlook and email offset values (four columns across) from the values it found.
I've generated a working example though it seems to be limited to only one example I've tested. I think I am approaching it from the wrong angle.
Sub SendReminderMail()
Dim p As Long
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
'If MsgBox("Are you sure?", vbYesNo) = vbNo Then Exit Sub
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
p = 2
Do Until Trim$(Cells(p, 1).Value) = ""
If Cells(p, 1).Value <= 10 Then
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.To = "Emailaddress etc"
.Subject = "Reminder: " & Cells(1, 7).Value
.Body = Cells(p, 1).Offset(0, 4).Value
.Display
End With
End If
p = p + 1
Loop
End Sub
How do I set it up to loop through all the <10 values and tell it to paste the offset values into the body of the email?
I think that you need to split this into two blocks of code.
First block would iterate through rows, check criteria and, if needed, call the second one, so the mail sending Sub, passing by necessary parameters.
Someting similar to the below code:
Sub SendReminderMail(ByVal MailSubject As String, mailBody As String)
Dim p As Long
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
'If MsgBox("Are you sure?", vbYesNo) = vbNo Then Exit Sub
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.To = "Emailaddress etc"
.Subject = MailSubject
.Body = mailBody
.Display
End With
End Sub
Sub IterateThroughRows()
Dim p As Integer
Dim Sht As Worksheet
Dim MailSubject As String
Dim mailBody As String
Set Sht = ThisWorkbook.Sheets("SheetName")
p = 2
Do Until Sht.Cells(p, 1).Value = ""
If Cells(p, 1).Value <= 10 Then
mailBody = mailBody + " | " + Sht.Cells(p, 1).Offset(0, 4).Value
End If
p = p + 1
Loop
Call SendReminderMail(MailSubject, mailBody)
MailSubject = "Reminder: " & Sht.Cells(1, 7).Value
End Sub
This is the first time I am trying from Excel to send email using VBA code.
Here is my structure of my Excel. Sometimes the email list will have 1 - 20 or only 1 also
A (col) B C D E F G
Sl.No First Name To Email CC Email Subj File to Send Message
Code:
Option Explicit
Sub SendMail()
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("C2")
Set rngSubject = .Range("E2")
Set rngBody = .Range("G2")
Set rngAttach = .Range("F2")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
Here is my code this was working perfectly fine but for single emails to send, but not for multiple email.
I am struggling here to find how to send for multiple email with attachment using the tested code.
Maybe Try this:
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim i As Integer
Set objOutlook = CreateObject("Outlook.Application")
For i = 2 To 21 ' Loop from 2 to 21
With ActiveSheet
Set rngTo = .Range("C" & i)
Set rngSubject = .Range("E" & i)
Set rngBody = .Range("G" & i)
Set rngAttach = .Range("F" & i)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.HTMLBody = "<B><U>" & rngBody.Value & ":</B></U>"
.Attachments.Add rngAttach.Value
.Display
End With
Set objMail = Nothing
Next
Set objOutlook = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
You can loop through the Range to generate 20 emails.
Update
Added .HTMLBody instead of .Body to make text Bold And Underlined
You can use more HTML commands to make certain portions of the Text Bold and More.
Try it this way.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
You need a loop for that. The below code will start with the second row and continue until it finds an empty row.
Option Explicit
Sub SendMail()
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")
Dim r As Long: For r = 2 To ActiveSheet.Range("C2").End(xlDown).Row
With ActiveSheet
Set rngTo = .Range("C" & r)
Set rngSubject = .Range("E" & r)
Set rngBody = .Range("G" & r)
Set rngAttach = .Range("F" & r)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.to = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
.Send ' If you want to send it without clicking
End With
Next
End Sub
Also note: These Set x = Nothing lines are superfluous, delete them because they just make the code less readable for humans. Regarding this issue you can also refer to this SO question: Is there a need to set Objects to Nothing inside VBA Functions
Update
Sorry this line has to be inside the loop, I updated the code:
Set objMail = objOutlook.CreateItem(0)