Is there a way to create a new Outlook email from Access 2002 without using the SendObject command? - vba

I have a client that is using Access 2002 because it allows Replication. He is using this on Windows 10 with Outlook from Office 365.
The goal is to create a new email with all of the info filled in and attach a scanned proposal so that my client can review the email, make any changes that he wants and then send it.
In Access, the SendObject command creates and opens a plain text email and while this email is open my Outlook macro to scan a document and attach it to the email will not run.
So I would like to create a new Outlook email from Access that allows me to run my Outlook macro.
Or if I could get Access 2002 to create an email and attach the scanned document to it, I think I could get by with using msgboxes to verify specific items.
Below is the Access macro with the SendObject command followed by the Outlook macro.
Private Sub EmailProposal_Click()
'Access macro.
Dim stDocName As String
Dim stEmailAddress As String
Dim stSubject As String
Dim stMessage As String
stDocName = "rptProposal"
stEmailAddress = Forms!RequestForm!EmailAddress.Value
stSubject = "PROPOSAL"
stMessage = "Your proposal is attached." & vbCrLf & vbCrLf & "If you have any questions, please call us."
'Email the proposal.
DoCmd.SendObject acReport, stDocName, acFormatRTF, stEmailAddress, , , stSubject, stMessage
End Sub
Sub Scan()
'Outlook macro.
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
On Error Resume Next
Dim objCommonDialog As WIA.CommonDialog
Dim objImage As WIA.ImageFile
Dim strPath As String
Set objCommonDialog = New WIA.CommonDialog
'This shows the dialog box. I'd rather tell it what to do instead of having to manually choose each time.
Set objImage = objCommonDialog.ShowAcquireImage
strPath = Environ("TEMP") & "\TempScan.jpg" 'Save the scan.
If Not objImage Is Nothing Then
objImage.SaveFile strPath ' save into temp file
On Error GoTo ErrHandler
If TypeName(ActiveWindow) = "Inspector" Then
If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
ActiveInspector.WordEditor.Application.Selection.Inlineshapes.AddPicture strPath 'Insert into email. I want to attach it instead.
End If
End If
Kill strPath
Else
MsgBox "The Scan macro in Outlook did not find a document." & vbCrLf & vbCrLf & _
"Please place the proposal in the printer so it can be scanned.", vbOKOnly
End If
lbl_Exit:
Set objImage = Nothing
Set objCommonDialog = Nothing
Exit Sub
ErrHandler:
Beep
Resume lbl_Exit
End Sub

It seems you just need to automate Outlook for sending out emails with the required content set up. Take a look at the following articles that give you the basics of Outlook automation:
Automating Outlook from a Visual Basic Application
Automating Outlook from Other Office Applications
Sub Send_Mail_Outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "eugene#astafiev.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Related

VBA Kill function not deleting file

I have written VBA code for Microsoft Word to send an email when a button is clicked. When the button is clicked, and the macro is completed, I would like the file to be deleted from the Desktop.
When I run this macro now, Microsoft Word closes out, but the file is not deleted from my desktop.
Here is my code:
Private Sub CommandButton1_Click()
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Dim FileName As String
Dim FilePath As String
Dim DeletePath As String
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
myFileName = "Form"
FilePath = "C:\Users\" & Environ("Username") & "\desktop\"
Doc.SaveAs2 FileName:=FilePath & myFileName & ".docx", Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
With EmailItem
.Subject = "Bid Award Form"
.Body = "Please Review the attached Bid Award form"
.To = "EMAILADDRESS#DOMAIN.COM"
.Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
.Attachments.Add Doc.FullName
.Send
End With
'display a message using named arguments
MsgBox _
prompt:="Your email has been sent. Please check your Outlook sent mail for confirmation", _
Buttons:=vbOKOnly, _
Title:="Email Confirmation"
'Close the File
Doc.Close
Kill "C:\Users\" & Environ("Username") & "\desktop\form.docx"
'Close the Application of the document we are going to delete
Application.Quit
Application.ScreenUpdating = True
Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
End Sub
Any help that you can provide will be very helpful!
Probably you are looking at the wrong file. Kill is a function, that makes no mistakes.
Simply try the following:
Sub KillTheFile
Kill "C:\Users\" & Environ("Username") & "\desktop\form.docx"
End Sub
Then see if it works. Probably you are having a file frm.docx or similar.
Try it like this instead
On Error Goto 0
Dim sDocName as string
sDocName = Doc.FullName
Doc.Close
Kill sDocName

"Save As" document link won't open, with error message ".. can't find .. correct location or web address"

I have an Excel Document in a Template. Users input information and Save As a new genericized number. They then hit a button that auto populates an email to one of 5 people using Vlookup and based on the cost margin.
The file is Save As'd but the e-mail recipient cannot open the file, it reads invalid location. I can close and reopen the new renamed sheet and drag it into an e-mail. I need to link to the newly saved file's name that appears in the email.
Sub Email_created_Workbook()
Dim OutApp As Object
Dim OutMail As Object
Dim Mess As Object, Recip
Recip = [Sheet1!B28].Value & "; " & [Sheet1!B27].Value
Dim strbody As String
If ActiveWorkbook.Path <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & _
"Hello,<br><br>" & _
"There is a New PO awaiting your approval :<br><B>" & _
ActiveWorkbook.Name & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & _
""">Link to Workbook</A>" & _
"<br><br>Regards," & _
"<br><br>Automated Approval System</font>"
On Error Resume Next
With OutMail
.To = Recip
.CC = ""
.BCC = ""
.Subject = ActiveWorkbook.Name
.HTMLBody = strbody
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Else
MsgBox "The ActiveWorkbook does not have a path, Save the file first."
End If
End Sub
The file name does adapt in my e-mail, from PO Template, but will not open.
I believe this will help you with your current issue (closing and reopening your file before sending). I've removed the the two lines of your code where you set the Outlook objects to Nothing. To reopen the current file you can use the OnTime function like so:
Sub Email_created_Workbook()
Dim OutApp As Object
Dim OutMail As Object
Dim Mess As Object, Recip
Recip = [Sheet1!B28].Value & "; " & [Sheet1!B27].Value
Dim strbody As String
If ActiveWorkbook.Path <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & _
"Hello,<br><br>" & _
"There is a New PO awaiting your approval :<br><B>" & _
ActiveWorkbook.Name & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & _
""">Link to Workbook</A>" & _
"<br><br>Regards," & _
"<br><br>Automated Approval System</font>"
On Error Resume Next
With OutMail
.To = Recip
.CC = ""
.BCC = ""
.Subject = ActiveWorkbook.Name
.HTMLBody = strbody
.Display 'or use .Send
End With
Application.OnTime Now + TimeValue("00:00:10"), "SendEmail"
ThisWorkbook.Close True 'True= yes, save changes
Else
MsgBox "The ActiveWorkbook does not have a path, Save the file first."
End If
End Sub
Sub SendEmail()
Dim OutApp As Object: Set OutApp = GetObject(, "Outlook.Application") 'Grab current instance of Outlook since we already opened the instance prior to restarting Excel
Dim oInspector As OutApp.Inspector: Set oInspector = OutApp.ActiveInspector
Dim NewMail As OutApp.MailItem: Set NewMail = oInspector.CurrentItem 'Grab currently open New/Compose Mail window
NewMail.Send 'Send Email
End Sub
Let me know if this helps resolve your issue.

Filter Email Attachments Files by Type

I have a script which sends a notification when no attachment was found on the email. Is it possible to check the file type of the attachment and send a notification if the file type is not the one needed.
Got the code like this.
Option Explicit
Public Sub CheckAttachment(Item As Outlook.MailItem)
Dim olInspector As Outlook.Inspector
Dim olDocument As Outlook.DocumentItem
Dim olSelection As Outlook.Selection
Dim objAtt As Outlook.Attachment
Dim ft As FileTypes
Dim olReply As MailItem
Dim FileExtension As String
FileExtension = "jpeg, jpg, tiff, pdf"
'// Check for attachment
If Item.Attachments.Count > 1 Then
GoTo CheckFileType1
End If
CheckFileType1:
If Item.Attachments(Item.Attachments, ".tiff") Then
GoTo CheckFileType2
End If
CheckFileType2:
If Item.Attachments(Item.Attachments, ".jpeg") Then
GoTo CheckFileType3
End If
CheckFileType3:
If Item.Attachments(Item.Attachments, ".pdf") Then
GoTo SendMail
Else
Exit Sub
End If
SendMail:
Set olReply = Item.Reply '// Reply if no attachment found
olReply.Body = "No attachment was found. Re-send the email and ensure that the needed file is attached." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & "This is a system generated message. No need to reply. Thank you."
olReply.Send
Set olInspector = Nothing
Set olDocument = Nothing
Set olSelection = Nothing
End Sub
Is it possible to check the file type of the attachment and send a notification if the filetype is not the one needed.
Yes, it is.
The Attachment class provides the FileName property which returns a string representing the file name of the attachment.
I would use select case function which will work much better
Option Explicit
Public Sub CheckAttachment(Item As Outlook.MailItem)
Dim olInspector As Outlook.Inspector
Dim olDocument As Outlook.DocumentItem
Dim olSelection As Outlook.Selection
Dim olReply As MailItem
Dim olAtt As Attachment
Dim olFileType As String
'// Check for attachment
If Item.Attachments.Count > 0 Then
For Each olAtt In Item.Attachments
'// The code looks last 4 characters,
'// including period and will work as long
'// as you use 4 characters in each extension.
olFileType = LCase$(Right$(olAtt.FileName, 4))
'// Select Case File type
Select Case olFileType
'// Add additional file types below as needed
Case ".pdf", "docx", ".doc", ".xls", "xlsx"
Exit Sub
Case Else
GoTo Reply
End Select
Next
Else
Reply:
Set olReply = Item.Reply '// Reply if no attachment found
olReply.Body = "No attachment was found. Re-send Attchment "
olReply.Send
End If
Set olInspector = Nothing
Set olDocument = Nothing
Set olSelection = Nothing
Set olAtt = Nothing
End Sub
Edit comments
for multiple lines try
olReply.Body = "Dear sender," & vbNewLine & vbNewLine & _
"We have received your e-mail " & vbNewLine & _
"and either there is no attachment or " & vbNewLine & _
"at least one of the attachments are invalid." & vbNewLine & vbNewLine
also look here how to Skip attachments in signatures

Excel email reminder to outlook when excel gets updated

Ok , so, anyone know if it is possible to send an email reminder from excel to outlook automatically every time the excel sheet gets updated? If so, how that part of the macro would look like? I cant find it online anywhere.
The following code seems to work.
Right click on a worksheet and select 'View code'
and select Change event for Worksheet.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "someone#someemail.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Refer to inbox of second account

I'm trying to look through a specific inbox for unread e-mails with .pdf files attached to them, and then save them into a specific folder.
I need to look through the inbox of certain account profile. My code only works if there is just one Inbox folder and one account profile.
Let's say I have two profiles;
One is xxxx#hotmail.com
The second zzzz#hotmail.com
How do I run the code on the Inbox of the second account?
(zzzz#hotmail.com)
The following is the code that I have so far;
Sub GetAttachments()
On Error GoTo GetAttachments_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Checks inbox for messages.
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in your Inbox.", vbInformation, _
"Nothing found"
Exit Sub
End If
' Checks inbox for unread messages.
If Inbox.UnReadItemCount = 0 Then
"Nothing found"
Exit Sub
End If
' Checks for unread messages with .pdf files attached to them, if yes then saves it to specific folder. _
Puts date and time from when the mail was created infront of the filename.
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Item.UnRead = True Then
If Right(Atmt.FileName, 3) = "pdf" Then
FileName = "C:\Users\XXX\Documents\Office Macro\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
End If
Next Atmt
Next Item
' Shows how many attached files there are if any are found.
If i > 0 Then
& vbCrLf & "Jag har sparat dem till C:\Users\XXX\Documents\Office Macro folder." _
& vbCrLf & vbCrLf & "Would you like to see your files?" _
vbQuestion + vbYesNo, "Finished!")
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Users\XXX\Documents\Office Macro\", vbNormalFocus
End If
Else
MsgBox "No attached files could be found.", vbInformation, _
"Finished!"
End If
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
GetAttachments_err:
MsgBox "An unkown ghost spooked the program." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
Exit Sub
End Sub
After further inspection of the mailboxes I see that there are some differences:
xxxx#hotmail.com is of the type "IMAP/SMTP"
zzzz#hotmail.com is of the type "Exchange ActiveSync"
I've also noticed that that the account ID I would need to use is 4, as seen in this code when sending a new message with a test-macro specifying what profile you want to send the mail from by assigning profile ID in the script:
Sub Mail_small_Text_Change_Account()
'Only working in Office 2007-2013
'Don't forget to set a reference to Outlook in the VBA editor
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "blabla#blabla.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
'SendUsingAccount is new in Office 2007
'Change Item(1)to the account number that you want to use
.SendUsingAccount = OutApp.Session.Accounts.Item(4) <<<< ACCOUNT ID
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
You get only the delivery store's inbox folder to find the items.
The Stores property of the Namespace class returns a Stores collection object that represents all the Store objects in the current profile. You can find the required store and then use the GetDefaultFolder method of the Store class instead. This method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile.
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
There is no need to create a new Outlook Application instance in Outlook VBA.
The Outlook object model provides the Find/FindNext or Restrict methods of the Items class. Also you may find the AdvancedSearch method of the Application class helpful.