I have the following VBA code for an E-Mail:
Sub Global_Email_Message()
Content = "<style> p {background-color: #d9d9d9} </style><p> This message should be global so I can use it in every sub for an E-Mail </p>"
If ExitAll = False Then
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
With OMail
.display
End With
signature = OMail.HTMLBody
With OMail
.To = "test#test.de"
.Subject = "test"
.HTMLBody = Content
End With
Set OMail = Nothing
Set OApp = Nothing
Else
End If
End Sub
This code works perfectly.
Now, I want to achieve that the message and the style in the variable "Content" is global so I can use it in different E-Mail-Subs. How can I globalize the "Content" variable for different E-Mail-Subs?
You need to declare the content variable with public outside the function:
Public content as String
Sub Global_Email_Message()
...
Related
I've included the last line of data entered to my HTML body. However the column headers are not showing, what am I doing wrong?
Private Sub cmdEmail_Click()
'Declare Outlook Variables
Dim OLApp As Outlook.Application
Dim OLMail As Object
Dim MyData As Object
'Open the Outlook Application and Start a new mail
Set OLApp = New Outlook.Application
Set OLMail = OLApp.CreateItem(0)
Set MyData = ThisWorkbook.Worksheets("Database").Cells(Rows.count, 1).End(xlUp).Resize(, 13)
OLApp.Session.Logon
With OLMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Quality Alert"
.HTMLBody = "<P><font size='6' face='Calibri' color='black'>Quality Issue Found<br><br> Please reply back with what adjustments have been made to correct this issue. </font></P>" & ConvertRangeToHTMLTable(ThisWorkbook.Worksheets("Database").Cells(Rows.count, 1).End(xlUp).Resize(, 13))
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Database")
Dim wb As Workbook
ws.Copy
Set wb = ActiveWorkbook
wb.SaveAs "C:\Temp\Database.xlsx" 'Change Path
.Display
' .Send
wb.Close SaveChanges:=False
Kill "C:\Temp\Database.xlsx"
End With
'Clearing Memory
Set OLMail = Nothing
Set OLApp = Nothing
End Sub
Only the 1st 13 columns of the last row are being targeted.
ThisWorkbook.Worksheets("Database").Cells(Rows.count, 1).End(xlUp).Resize(, 13)
I order to include all the data, you'll have to extend the range from the first cell to the last row.
With ThisWorkbook.Worksheets("Database")
Set MyData = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Resize(, 13))
End With
Breaking up the code into smaller bites will allow you to easily isolate and test your code.
Extracting the code that targets the data range into its own function (in a public module) allows use Application.Goto to visibly inspect the range.
Application.Goto EmailData
Private Sub cmdEmail_Click()
Dim HTMLBody As String
HTMLBody = EmailHTMLFirstAndLastRow
SendEmail HTMLBody
CreateACopyOfTheDatabaseSaveItCloseKillItButNeverDoAnythingWithit
End Sub
Place this code in a public module:
Sub SendEmail(HTMLBody As String)
'Declare Outlook Variables
Dim OLApp As Outlook.Application
Dim OLMail As Object
Dim MyData As Object
'Open the Outlook Application and Start a new mail
Set OLApp = New Outlook.Application
Set OLMail = OLApp.CreateItem(0)
OLApp.Session.Logon
With OLMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Quality Alert"
.HTMLBody = "<P><font size='6' face='Calibri' color='black'>Quality Issue Found<br><br> Please reply back with what adjustments have been made to correct this issue. </font></P>" & HTMLBody
.Display
' .Send
End With
'Clearing Memory
Set OLMail = Nothing
Set OLApp = Nothing
End Sub
Function EmailHTMLFirstAndLastRow() As String
Dim Target As Range
Set Target = EmailData
With Target
.EntireRow.Hidden = msoTrue
.Rows(1).Hidden = msoFalse
.Rows(.Rows.Count).Hidden = msoFalse
.EntireRow.Hidden = msoFalse
End With
EmailHTMLFirstAndLastRow = RangetoHTML(Target.Rows(Target.Rows.Count))
End Function
Function EmailData() As Range
With ThisWorkbook.Worksheets("Database")
Set EmailData = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Resize(, 13))
End With
End Function
Sub CreateACopyOfTheDatabaseSaveItCloseKillItButNeverDoAnythingWithit()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Database")
Dim wb As Workbook
ws.Copy
Set wb = ActiveWorkbook
wb.SaveAs "C:\Temp\Database.xlsx" 'Change Path
wb.Close SaveChanges:=False
Kill "C:\Temp\Database.xlsx"
End Sub
Edit
I edited the code to create html for only the header and last rows, as per the OP's request. Since RangetoHTML() ignores hidden rows, I define the range of data, hid all but the fist and last rows, the passed the range to RangetoHTML() and assigned its value to a variable, the unhid the range.
I'm trying to improve my knowledge of MS Access to benefit my companies operations. at the moment I'm trying to use information from a Form to populate an email. I've kept it basic to ensure I have the theory correct before adding further information.
I have a table called ClientListtbl and a Form called ClientListfrm.
I want a button to generate an email prepopulated with the Email Address (field named is EmailAddress) in the "TO" part of the email and the Last Name (field named LastName) in the subject. I will want to put a "Notes" field into the email body eventually but thought better to start small.
after trawling stackoverflow and other resources I came across a code that seemed to fit and retrofitted it to my database, the code is as follows:
Private Sub Command20_Click()
Dim LastName As Variant
Dim Email As Variant
Dim objOutlook As Object
Dim objEmail As Object
LastName = ClientListfrm!LastName
Email = ClientListfrm!EmailAddress
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(0)
With objEmail
.To = Email
.Subject = LastName
.send
End With
Set objEmail = Nothing
Set objOutlook = Nothing
End Sub
EmailAddress is short text
LastName is Short text
when I then click the button I get an error stating
run-time error '424' Object required
clicking on debug LastName = ClientListfrm!LastName is highlighted. So i tried changing LastName and EmailAddress to As Object. which gives the same error.
any help much appreciated.
cheers
This - with a reference to Outlook - works for me:
Private Sub Command20_Click()
Dim LastName As Variant
Dim Email As Variant
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
LastName = "Macron" 'ClientListfrm!LastName
Email = "someone#example.com" 'ClientListfrm!EmailAddress
Set objOutlook = Outlook.Application
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = Email
.Subject = LastName
.send
End With
Set objEmail = Nothing
Set objOutlook = Nothing
End Sub
So, what's missing is probably the syntax for the form controls:
LastName = Forms!ClientListfrm!LastName.Value
Email = Forms!ClientListfrm!EmailAddress.Value
Simply a syntax error in the way you are trying to call the field in the form. This worked for me, but there may be other methods:
Private Sub Command20_Click()
Dim LastName As Variant
Dim Email As Variant
Dim objOutlook As Object
Dim objEmail As Object
LastName = Forms("ClientListfrm").LastName
Email = Forms("ClientListfrm").EmailAddress
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(0)
With objEmail
.To = Email
.Subject = LastName
.send
End With
Set objEmail = Nothing
Set objOutlook = Nothing
End Sub
I utilize Excel to mass mail clients. My VBA code can't locate the HTML jpeg for the advertisement.
Is the imgur link not good or is it my code?
MailWindows()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "insert here"
.Attachments.Add Fname, 1, 0
.HTMLBody = "<img src=""cid:"https://url.jpeg height=1650 width=1275>"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Besides the quote problems, you are referring to an image through cid (content-id), which means the email client must look for an attachment in the same message with the Content-ID MIME header set to https://url.jpeg.
If you meant to refer to an external image, it needs to be
.HTMLBody = "<img src=""https://url.com/someimage.jpeg"" height=1650 width=1275>"
If you refer to an embedded image, you need to actually add the attachment and set PR_ATTACH_CONTENT_ID MAPI property appropriately using Attachment.PropertyAccessor.SetProperty
I have an Access 2016 database with tables that hold student data. I have managed to successfully send an email to each recipient using VBA-Outlook (the code works), however, it looks to have sent the the email to the same recipients multiple times (random duplicate of 1 to 4 emails per recipient).
I can confirm that there are no duplicate [E-mail Address] whatsoever contained within the Student table.
When I use .Display instead of .Send in my oEmailItem, there does not appear to be any duplicates. Perhaps I should include a waiting period of 1 second in the loop?
On Error Resume Next is used to bypass the null value returned by blank email fields; not everyone has an [E-mail Address] in this table
Why is this code sending random duplicate email to recipients?
Private Sub SendEmail_Click()
Dim rS As DAO.Recordset
Dim dbS As DAO.Database
Dim Filepath As String
Dim Folderpath As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim myemail As String
Dim Subjectline As String
Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
"We need a Subject Line!")
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("SELECT * FROM Students")
Do While Not rS.EOF
On Error Resume Next
myemail = rS![E-mail Address]
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
'Set the email template
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
With oEmailItem
.To = [myemail]
.Subject = Subjectline$
.Send
End With
'End of emailing
rS.MoveNext
Loop
Set oEmailItem = Nothing
Set oOutlook = Nothing
Set rS = Nothing
Set dbS = Nothing
End Sub
Update:
Thanks HiPierr0t. Your answer showed me that I wasn't emptying the variable at the end of the loop; thus assigning the previously used [E-mail Address] when met with a null or blank email field.
I did have to keep
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
inside the loop however (strange, must be a MS thing).
I ended up removing On Error Resume Next as it does create more problems, and used
myemail = Nz(rS![Email Address], vbNullString)
to change any null or blank fields into "". That way, I don't need to empty to variable each time as the lookup changes it to "" if it's null anyway. The If..Else takes care of the rest.
Do While Not rS.EOF
'On Error Resume Next
myemail = Nz(rS![Email Address], vbNullString)
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
If myemail = "" Then
rS.MoveNext
Else
With oEmailItem
.To = [myemail]
.Subject = Subjectline$
.Display
End With
'End of my emailing report
rS.MoveNext
End If
Loop
On Error Resume Next tends to create more problems than it solves.
If no email exists, your code goes on. However your variable myemail is still filled with the previous email you sent an email to.
1- Make sure to empty your variable after the email is sent with myemail = "" or myemail = vbNullString.
2- Before sending the email, check that myemail is not empty with an If statement.
3- You may want to place your code below outside of the loop. It won't make a big difference but there is no need to process this part of code every time.
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
'Set the email template
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
Please check if you’ve emptied the myemail before sending e-mail.
Also you need to add “rS.Close dbS.Close” after the Loop.
Here is complete code:
Private Sub SendEmail_Click()
Dim rS As DAO.Recordset
Dim dbS As DAO.Database
Dim Filepath As String
Dim Folderpath As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim myemail As String
Dim Subjectline As String
Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
"We need a Subject Line!")
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("SELECT * FROM Students")
Do While Not rS.EOF
On Error Resume Next
myemail = ""
myemail = rS![E-mail Address]
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
'Set the email template
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
With oEmailItem
.To = [myemail]
.Subject = Subjectline$
.Send
End With
'End of emailing
rS.MoveNext
Loop
rS.Close
dbS.Close
Set oEmailItem = Nothing
Set oOutlook = Nothing
Set rS = Nothing
Set dbS = Nothing
End Sub
I am trying to send a fax from Outlook using a different Outlook address than mine which is the one that it defaults to. Below is my code.
Thank you.
Private Sub FaxDoctor() ' Faxes the doctor with the letter
On Error GoTo Error_Handler
Dim fso
Dim olApp As Object
' Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olfolder As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists("\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf") Then ' If the filename is found
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olfolder = olNS.GetDefaultFolder(olFolderInbox)
Set olMailItem = olfolder.Items.Add("IPM.Note")
olMailItem.display
With olMailItem
.Subject = " "
.To = "[fax:" & "Dr. " & Me.[Prescriber First Name] & " " & Me.[Prescriber Last Name] & "#" & 1 & Me!Fax & "]" ' Must be formatted exactly to be sent as a fax
'.Body = "This is the body text for the fax cover page" ' Inserts the body text
.Attachments.Add "\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf" ' attaches the letter to the e-mail/fax
'.SendUsingAccount = olNS.Accounts.Item(2) 'Try this to change email accounts
End With
Set olMailItem = Nothing
Set olfolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Else
GoTo Error_Handler
End If
Exit_Procedure:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox ("No Letter found" & vbCrLf & "If you are certain the letter is saved with the correct filename then close down Outlook and try again.") ' This often crashes because the letter is not found or because outlook has crashed. In which case every Outlook process should be closed and Outlook should be restarted.
Exit Sub
End Sub
You can change the outlook account by using the 'SendUsingAccount' property of the mail item. This needs to be set to an account object.
You can set the account for a given name using something like this where 'AccountName' is the address you're sending from.
Dim olAcc as Outlook.Account
For Each olAcc In Outlook.Session.Accounts
If outAcc.UserName = 'AccountName' Then
olMailItem.SendUsingAccount = outAcc
Exit For
End If
Next
Try using ".SendOnBehalfOfName"
I found this function online, so just follow its lead:
Function SendEmail()
Dim Application As Outlook.Application
Dim NameSpace As Outlook.NameSpace
Dim SafeItem, oItem ' Redemption
Set Application = CreateObject("Outlook.Application")
Set NameSpace = Application.GetNamespace("MAPI")
NameSpace.Logon
Set SafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem
Set oItem = Application.CreateItem(0) 'Create a new message
SafeItem.Item = oItem 'set Item property
SafeItem.Recipients.Add "customer#ispprovider.com"
SafeItem.Recipients.ResolveAll
SafeItem.Subject = "Testing Redemption"
SafeItem.SendOnBehalfOfName = "Invoices#companyname.com"
SafeItem.Send
End Function