i have this code to send emails but i need to send an Report of access after created, i have this code to send email:
User = Environ$("username")
emailDC = "email#email.com"
Dim mess_body As String
Dim appOutLook As Object
Dim MailOutLook As Object
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.To = emailDC
.Subject = User
.HTMLBody = "Try access to file"
.DeleteAfterSubmit = True 'This would let Outlook send th note without storing it in your sent bin
.Send
End With
'MsgBox MailOutLook.Body
Exit Sub
email_error:
MsgBox "An error was encountered." & vbCrLf & "The error message is: " & Err.Description
Resume Error_out
Error_out:
But i need to send this with a report in .pdf
Save the Report as a .pdf
Use the DoCmd.OutputTo method to generate the pdf :
DoCmd.OutputTo _
acOutputReport, "Your Report Name", _
acFormatPDF, "A:\Temporary\Place\To\Store\Report.pdf", _
False,"", 0, acExportQualityPrint
MailItem has an Attachments property that allows you to Add attachments :
With MailOutLook
'...
.Attachments.Add(yourReportPath)
'...
End With
Related
I am using below query in Access VBA to import emails from outlook, however i am not able to find any details to capture email address instead of From or along with From. any help can be appricated.
Sub InboxImport()
Dim SqlString As String
Dim ConnectionString As String
Dim EmailTableName As String
Dim UserIdNum As String
Dim EmailAddr As String
Dim ol As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFol As Outlook.Folder
Set ol = CreateObject("Outlook.Application")
Set olNS = ol.GetNamespace("MAPI")
Set olFol = olNS.GetDefaultFolder(olFolderInbox)
EmailTableName = "MyInbox" 'My table name
UserIdNum = Environ("USERNAME")
EmailAddr = olFol.Parent.Name
ConnectionString = "Outlook 9.0;MAPILEVEL=Test#Me.com|;PROFILE=Default Outlook Profile;TABLETYPE=0;TABLENAME=Inbox;COLSETVERSION=12.0;DATABASE=C:\Users\ME\AppData\Local\Temp\"
SqlString = "SELECT [From] As [Sender], [Sender Name] As SenderName, [Subject Prefix] & [Normalized Subject] As Subject, [Contents] As [Body], [Received] As [ReceivedTime]" & _
" INTO [Copy Of APR_DATA]" & _
" From [" & ConnectionString & "].[Inbox]"
DoCmd.RunSQL SqlString
End Sub
Set a link to Outlook Inbox folder and will see From field showing either sender's email address or an alias but no other field with sender address. Possibly masked email address cannot be retrieved via query. It can be retrieved by reading SenderEmailAddress property of an email item. Consider:
' Procedure : Outlook_ExtractMessages
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Extract E-mail Listing
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Usage:
' ~~~~~~
' Call Outlook_ExtractMessages
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2019-07-15 Initial Release
'---------------------------------------------------------------------------------------
Sub Outlook_ExtractMessages()
Dim oOutlook As Object 'Outlook.Application
Dim oNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object 'Outlook.folder
Dim oItem As Object
Dim oPrp As Object
Const olFolderInbox = 6
Const olMail = 43
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
If Err.Number <> 0 Then 'Could not get instance, so create a new one
Err.Clear
Set oOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo Error_Handler
Set oNameSpace = oOutlook.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderInbox)
' Set oFolder = oOutlook.ActiveExplorer.CurrentFolder 'Process the currently selected folder
' Set oFolder = oNameSpace.PickFolder 'Prompt the user to select the folder to process
On Error Resume Next
For Each oItem In oFolder.Items
With oItem
If .Class = olMail Then
Debug.Print .SenderEmailAddress ' .body, .EntryID, .Subject, .Sender, .SentOn, .ReceivedTime
'For Each oPrp In .ItemProperties
' Debug.Print , oPrp.name, oPrp.Value
'Next oPrp
End If
End With
Next oItem
Error_Handler_Exit:
On Error Resume Next
If Not oPrp Is Nothing Then Set oPrp = Nothing
If Not oItem Is Nothing Then Set oItem = Nothing
If Not oFolder Is Nothing Then Set oFolder = Nothing
If Not oNameSpace Is Nothing Then Set oNameSpace = Nothing
If Not oOutlook Is Nothing Then Set oOutlook = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Outlook_ExtractMessages" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
I am trying to get my VBA/HTML to automatically send emails at a specific time, however as the time I have it set to test at comes and goes, nothing happens. When I go to activate it manually, the debugger highlights the time value and says "invalid outside procedure". I am new to VBA and was wondering if anyone could help?
Application.OnTime TimeValue("14:31:00"), Procedure = "RangetoHTML"
Function RangetoHTML(rng As Range)
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Sub AutoEmail()
' You need to use this module with the RangetoHTML subroutine.
' Working in Office 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Sheets("emailtest").Range("A10:E39").SpecialCells(xlCellTypeVisible) ' Change this
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Range("C6").Value ' Change this to the email addresses you want to send to
.CC = ""
.BCC = ""
.Subject = Date & " " & "Daily MCAPS Part Update" ' Add in a subject
.HTMLBody = Range("C5").Value
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Your function Function RangetoHTML(rng As Range) needs a parameter. So, it must be passed when it is called. But I do not have the knowledge to be possible to directly send an object like parameter and you must make a kind of trick. The function parameter must be declared As String and the range address will be sent and the range will be built inside the function. Something like this:
Function RangetoHTML(rngAdd As String)
Dim rng As Range
Set rng = Range(rngAdd)
'then use it like you need
End Function
And the function will be called in this way:
Application.OnTime TimeValue("14:31:00"), "'RangetoHTML """ & rng.address & "'"
I am using the below code. It works find without the attachment line of code. But once I add the attachment line if get an error and can not work out how to correct it:
Dim Email
Dim CC
Dim objOutlook As Object
Dim objEmail As Object
Dim db As Database
Dim rec As Recordset
'Export report in same folder as db with date stamp
todayDate = Format(Date, "MMDDYYYY")
fileName = Application.CurrentProject.Path & "\XXDispute_" & todayDate & ".pdf"
DoCmd.OutputTo acReport, "XXDispute", acFormatPDF, fileName, False
strItem = "http://schemas.microsoft.com/cdo/configuration/"
strFrom = "XX Disputes <asd#asd.com>"
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = CreateObject("CDO.Message")
With objEmail
.To = "asd#asd.com"
.CC = ""
.From = strFrom
.Subject = "XXDispute Report: " & Now()
.Textbody = "Your XX dispute has been reviewed and responded to:" & vbNewLine & vbNewLine
.Attachments Add = fileName
With .Configuration.Fields
.Item(strItem & "sendusing") = 2
.Item(strItem & "smtpserver") = "mailhost"
.Item(strItem & "smtpserverport") = 25
.Update
End With
.Send
End With
This is the particular line causing the problem:
.Attachments Add = fileName
This code is working in another Access db.
I just copy pasted the code but there is an error in the first line.
Public Function sendEmailOutlook()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
On Error GoTo ErrHandler:
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("sads")
'Set objOutlookRecip = .Recipients.Add("niticin#gmail.com")
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "This is an automatic confirmation"
.Body = "This is a confirmation of the" & Form_Booking.Event_Name.Value & vbCrLf & _
"Client: " & Form_Booking.FirstName.Value & vbCrLf & vbCrLf & _
"Start Time: " & Form_Booking.Actual_Start_Time.Value
.Importance = olImportanceHigh 'High importance
.Save
.Send
End With
'Set objOutlookMsg = Nothing
Set objOutlook = Nothing
Exit Function
ErrHandler:
MsgBox ("Make sure your Outlook is active and configured!")
End Function
Error on line
Dim objOutlook As Outlook.Application
compiler : user defined type not defined.
You're using early binding, so in the VBA Editor you need to click Tools -> References & tick Microsoft Outlook ?? Object Library in order to expose Outlook's object model to your code.
I need to send a series of email notifications from an MS Access Database.
No third party dll's like Redemption
Cannot trip the outlook security warnings
The email will have a pdf attachment
I know to do this I need to use MAPI, but I can't seem to find a way to do this with VBA.
Any help would be appreciated
Thanks,
Scott
If you can live with requiring CDO to be present on the machine, and you don't mind a user-provided SMTP server, you can use that. Just google for some example code, but for you convenience I'll paste some below from www.rondebruin.nl :
Sub CDO_Mail_Small_Text()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
' Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
' = "Fill in your SMTP server here"
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
With iMsg
Set .Configuration = iConf
.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.From = """Ron"" <ron#something.nl>"
.Subject = "Important message"
.TextBody = strbody
.Send
End With
End Sub
Adding an attachment would be done using .AddAttachment "C:\files\filename.pdf" on the iMsg.
If the user has outlook installed:
Dim strErrMsg As String 'For Error Handling
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim oleGrf As Object
Dim strFileName As String
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olMail = olApp.CreateItem(olMailItem)
Set oleGrf = Me.OLEchart.Object
strFileName = "c:\temp\Graph.jpg"
oleGrf.Export FileName:=strFileName
With olMail
.To = "someone#somewhere.com"
.Subject = "Graph Info " & Format(Now(), "dd mmm yyyy hh:mm")
.Attachments.Add strFileName
.ReadReceiptRequested = False
.Send
End With
Kill strFileName
Also check out Tony Toews's Microsoft Access Email FAQ
See the page Microsoft Access Email FAQ - Directly via the Winsock I haven't tried those myself but you should be able to adapt the VB6 code to send the emails directly.