Adding active spreadsheet as attachment to email

[Christowl]

Hi Folks,

Been a while since I've been on here so hope that you're all doing well.

I've been working on an application (Excel 2013) at work that will effectively validate entries, protect the document, save it to a new folder and then email (Lotus Notes) it to a range of people who are in a range on another sheet in the file.

I'm fairly close to completing (I think!) but I'm stuck when it comes to adding the attachment to the email and it seems once again file structures are screwing me. I'm not sure how I could but another possibility would be to change the code to attach the active document?

The code is below if anybody feels that they can help;

Sub SendNotesMail()
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim Session As Object
Dim AttachME As Object
Dim Recipient As String
Dim Subject1 As String
Dim MyFile As String
Dim ccRecipient As String
Set Session = CreateObject("Notes.NotesSession")
MyFile = Sheets("Request form").Range("F9").Text
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else: Maildb.OpenMail
End If
Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"
Recipient = Sheets("control").Range("A2").Value
MailDoc.SendTo = Recipient
ccRecipient = Sheets("control").Range("A2").Value
MailDoc.CopyTo = ccRecipient
MailDoc.BlindCopyTo = Sheets("control").Range("A2:A4").Value
Subject1 = Sheets("control").Range("A2").Value
MailDoc.Subject = "Request for quotation"
MailDoc.Body = "Dear Supplier," & vbNewLine & vbNewLine & "Please find attached a request for quotation." & vbNewLine & vbNewLine & "King Regards," & vbNewLine & "Rob\Susanne"
MailDoc.SaveMessageOnSend = True
Attachment1 = "M:\Supply Chain\RFQ\" & MyFile
If Attachment1 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CREATERICHTEXTITEM("attachment1")
Set EmbedObj1 = AttachME.EmbedObject(1454, "attachment1", "M:\Supply Chain\RFQ\" & MyFile, "")
On Error Resume Next
End If

MailDoc.PostedDate = Now
Call MailDoc.Send(False)
Set Maildb = Nothing:
Set MailDoc = Nothing:
Set Session = Nothing
Exit Sub
End Sub

Before anyone asks, yes, I'm a newb lol

Thanks in advance,

Chris

[Kenneth Hobs]

See: http://vbaexpress.com/forum/showthread.php?t=21561

[Christowl]

Hi, I'm not sure this is what I'm looking for as I want to attach the current file rather than one saved in a directory.

[Kenneth Hobs]

Exactly. Naturally, you would use FileCopy or FileSaveAs first.

[Christowl]

Okay, I've done this and now I get a warning message saying object required, not sure why;

Sub SendNotesMail()
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim Session As Object
Dim AttachME As Object
Dim Recipient As String
Dim Subject1 As String
Dim MyFile As String
Dim ccRecipient As String
Dim stAttachment As String
Dim obAttachment As Object, EmbedObject As Object
Const EMBED_ATTACHMENT As Long = 1454
Set Session = CreateObject("Notes.NotesSession")
FileSaveAs = "M:\Supply Chain\RFQ\TEMP.xls"
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else: Maildb.OpenMail
End If
Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"
Recipient = Sheets("control").Range("A2").Value
MailDoc.SendTo = Recipient
ccRecipient = Sheets("control").Range("A2").Value
MailDoc.CopyTo = ccRecipient
MailDoc.BlindCopyTo = Sheets("control").Range("A2:A4").Value
Subject1 = Sheets("control").Range("A2").Value
MailDoc.Subject = "Request for quotation"
stAttachment = "M:\Supply Chain\RFQ\TEMP.xls"
MailDoc.Body = "Dear Supplier," & vbNewLine & vbNewLine & "Please find attached a request for quotation." & vbNewLine & vbNewLine & "King Regards," & vbNewLine & "Rob\Susanne"
Set noDocument = noDatabase.CreateDocument
Set obAttachment = noDocument.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now
Call MailDoc.Send(False)
Set Maildb = Nothing:
Set MailDoc = Nothing:
Set Session = Nothing
Exit Sub
End Sub

[Christowl]

Anybody have any ideas with this? Everything I try creates a different error message.

[Kenneth Hobs]

Did you put that in a Module? While in the Sub, press F8 to execute each line to see where the error lies if the Run does not show it properly. After executing each line, place cursor over a variable to see what value it resolved to.

The method below shows how to use FSO to copy a file.

Sub test()
    Make [A1].Value, [A2].Value
End Sub
 
 
Sub Make(pathTemplate As String, pathNew As String)
     'No trailing "\" in path names assummed.
    Dim fso As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(pathNew) Then fso.CreateFolder pathNew
    fso.CopyFolder pathTemplate, pathNew, True 'True=Overwrite if files exist
    fso.CopyFile ThisWorkbook.FullName, pathNew & "\" & ThisWorkbook.Name
End Sub

[Christowl]

Hi Kenneth,

Apologies for the delay, been off work.

The code at the minute doesn't create an error message, it still sends an email but it doesn't create the attachment required.

Sub SendNotesMail()
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim Session As Object
Dim AttachME As Object
Dim Recipient As String
Dim Subject1 As String
Dim MyFile As String
Dim ccRecipient As String
Set Session = CreateObject("Notes.NotesSession")
MyFile = Sheets("Request form").Range("F9").Text
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else: Maildb.OpenMail
End If
Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"
Recipient = Sheets("control").Range("A2").Value
MailDoc.SendTo = Recipient
ccRecipient = Sheets("control").Range("A2").Value
MailDoc.CopyTo = ccRecipient
MailDoc.BlindCopyTo = Sheets("control").Range("A2:A4").Value
Subject1 = Sheets("control").Range("A2").Value
MailDoc.Subject = "Request for quotation"
MailDoc.Body = "Dear Supplier," & vbNewLine & vbNewLine & "Please find attached a request for quotation." & vbNewLine & vbNewLine & "King Regards," & vbNewLine & "Rob\Susanne"
MailDoc.SaveMessageOnSend = True
Attachment1 = "M:\Supply Chain\RFQ\" & MyFile & ".xlsm"
If Attachment1 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CreateRichTextItem("attachment1")
Set EmbedObj1 = AttachME.EmbedObject(1454, "attachment1", "M:\Supply Chain\RFQ\" & MyFile, ".xlsm")
On Error Resume Next
End If

MailDoc.PostedDate = Now
Call MailDoc.Send(False)
Set Maildb = Nothing:
Set MailDoc = Nothing:
Set Session = Nothing
Exit Sub
End Sub

[Kenneth Hobs]

Change the last , to an & in:

Set EmbedObj1 = AttachME.EmbedObject(1454, "attachment1", "M:\Supply Chain\RFQ\" & MyFile, ".xlsm")

[Christowl]

It now reads

Set EmbedObj1 = AttachME.EmbedObject(1454, "attachment1", "M:\Supply Chain\RFQ\" & MyFile & ".xlsm")

But I still get EmbedObj1=Empty.

[worthm]

This way seems like a lot of work. Try this. I've changed the real email to a dummy email youremail@yahoo.com
This short string of code opens an email, attaches your spreadsheet, and adds a line of text to the subject line in the email

Sub SendIt()
Application.Dialogs(xlDialogSendMail).Show arg1:="youremail@yahoo.com", _
arg2:="This is your FNOL audit file"
End Sub

I then created a macro which points to this piece of code. Pretty easy

[Kenneth Hobs]

IF the file does not exist, you get the same thing. If this is True, then it exists.

Sub ken()  Dim MyFile As String, s As String
  MyFile = "ken"
  s = "M:\Supply Chain\RFQ\" & MyFile & ".xlsm"
  MsgBox Dir(s) <> ""
End Sub

[Christowl]

Ken,

Thank you so much for your help. All working now!

Much appreciated,

Chris