Another Lotus Notes Query

Gidday -

I have been working on some code which I got from Ivan Moala written by Dennis XL that allows you to email from within Excel. Now the code works fine but what I need to do is create another object as a workbook copy a sheet from the active workbook then attach this to the e-mail. The code I have been working on simply copys a range from a sheet the pastes this onto the e-mail. Have had a number of attempts and all crash.

Have read another query in this forum but there is no link???.

It's always the little details that cause the problems!!!!!!:exclamat::exclamat:

PS - this formum has helped me heaps - thanks to all for the help I've recieved.

Phil:thumbcoo:

I have been playing with this code:

Sub Send_Range_Lotus()
'Using late binding for Lotus
'A reference to Microsoft Forms 2.0 object library must be set.


Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim stSubject As Variant, stTitle As String
Dim vaRecipient As Variant, vaMsg As Variant
Dim rnBody As Range
Dim Data As DataObject


stSubject = "Colour Control Data"


Do
vaRecipient = Application.InputBox( _
            Prompt:="please enter the recipient mailaddress:" & _
            vbCrLf & "([email protected] or just the name - will look at the Lotus Notes phonebook for a match)", _
            title:="Recipient", _
            Type:=2)
Loop While vaRecipient = ""


If vaRecipient = False Then Exit Sub


Do
vaMsg = Application.InputBox( _
       Prompt:="Please enter any text to send with the attached workbook:", _
       title:="Message", _
       Type:=2)
Loop While vaMsg = ""


On Error Resume Next
Set rnBody = Worksheets("Analysis Check").Range("A1:Z100")
If rnBody Is Nothing Then Exit Sub
On Error GoTo 0


Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")


If noDatabase.IsOpen = False Then noDatabase.OPENMAIL


Set noDocument = noDatabase.CreateDocument
rnBody.Copy
Set Data = New DataObject
Data.GetFromClipboard


With noDocument
    
    .Form = "Memo"
    .SendTo = vaRecipient
    .Subject = stSubject
    .Body = vaMsg & Data.GetText
    .SaveMessageOnSend = True
End With


noDocument.PostedDate = Now()
noDocument.Send 0, vaRecipient


Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing


AppActivate "Microsoft Excel"
Application.CutCopyMode = False


MsgBox "E-mail has been created and sent.", vbInformation


End Sub

Now this will send an e-mail to one recipent, but idealy I want to send the selected range as an attachment .i.e create a new workbook copy the range across and then attach it. This code get's me 60% of the way there. Am now talking to our IT manager who thinks he may have some other code so will send this when I manage to get this thing to fly.................. Thanks for the code, I'm still playing with it but it's a bit over my head!!!!!!!!!!!!!!:tumble:

OK, this works within Excel 2000 - attaches the spreadsheet detailed in the pathway - needs work to sort out and fine tune but................

Private Sub SendNotesMail()
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim EmbedObj1 As Object
Dim EmbedObj2 As Object
Dim EmbedObj4 As Object
Dim EmbedObj5 As Object
Dim EmbedObj6 As Object
Dim EmbedObj7 As Object
Dim EmbedObj8 As Object
Dim EmbedObj9 As Object
Dim EmbedObj10 As Object
Set Session = CreateObject("Notes.NotesSession")
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 = Range("A15").Value
MailDoc.sendto = Recipient
ccRecipient = Range("B15").Value
MailDoc.CopyTo = ccRecipient
bccRecipient = Range("C15").Value
MailDoc.BlindCopyTo = bccRecipient
Subject = Range("D15")
MailDoc.Subject = Subject
BodyText = Range("B8")
MailDoc.Body = BodyText
MailDoc.SAVEMESSAGEONSEND = True
Attachment1 = ThisWorkbook.Path + "/" + "Book1.xls"
If Attachment1 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment1")
On Error Resume Next
Set EmbedObj1 = AttachME.EMBEDOBJECT(1454, "", Attachment1, "Attachment")
On Error Resume Next
MailDoc.CREATERICHTEXTITEM ("Attachment")
On Error Resume Next
End If


MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
Set EmbedObj2 = Nothing
Set EmbedObj3 = Nothing
Set EmbedObj4 = Nothing
Set EmbedObj5 = Nothing
Set EmbedObj6 = Nothing
Set EmbedObj7 = Nothing
Set EmbedObj8 = Nothing
Set EmbedObj9 = Nothing
Set EmbedObj10 = Nothing
Exit Sub
errorhandler1:
Application.Goto Reference:="IAddress"
CellLocation99 = ActiveSheet.Name & "!" & ActiveCell.Address
Worksheets("Address Complications").Select
Range("a1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveCell = CellLocation99
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
Set EmbedObj2 = Nothing
Set EmbedObj3 = Nothing
Set EmbedObj4 = Nothing
Set EmbedObj5 = Nothing
Set EmbedObj6 = Nothing
Set EmbedObj7 = Nothing
Set EmbedObj8 = Nothing
Set EmbedObj9 = Nothing
Set EmbedObj10 = Nothing
End Sub

Still a problem with the error handling on the error routine but.......... the e-mail carried the attachment!!!! :jumpupdo: :viking: :thumbcoo:

Thanks - Ivan you link sorted it out for me - needed to sort out the attachment code. I'm bloody stocked!!!

Here's the final code: and spreadsheet for all to see.

Thanks all for help on this

Just updating - improved the attachment system to allow you to browse the hard drive - could be improved for mulitiple attachments by following the way the attachment system works and running a loop

Attachment system must still be down!!!

No major here is the code

Dim Maildb As Object
Dim Username As String
Dim MailDbName As String
Dim MailDoc As Object
Dim attachME As Object
Dim session As Object
Dim EmbedObj1 As Object
Dim recipient As String
Dim ccRecipient As String
Dim bccRecipient As String
Dim subject As String
Dim bodytext As String
Dim Attachment1 As String
Option Explicit

Private Sub CommandButton1_Click()
' setting up all sending recipients
recipient = tobox.value
ccRecipient = copy.value
bccRecipient = Bcopy.value
subject = subject1.value
bodytext = TextBox1.value

'// Lets check to see if form is filled in Min req =Recipient, Subject, Body Text
If recipient = vbNullString Or subject = vbNullString Or bodytext = vbNullString Then
MsgBox "Recipient, Subject and or Body Text is NOT SET!", vbCritical + vbInformation
Exit Sub
End If

' creating a notes session
Set session = CreateObject("Notes.NotesSession")
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
On Error Resume Next
Maildb.OPENMAIL
End If

Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"

' loading the lotus notes e-mail with the inputed data
With MailDoc
.sendto = recipient
.copyto = ccRecipient
.blindcopyto = bccRecipient
.subject = subject
.body = bodytext
End With

' saving message
MailDoc.SaveMessageOnSend = True

If Attachment1 <> "" Then
Set attachME = MailDoc.CREATERICHTEXTITEM("Attachment1")
Set EmbedObj1 = attachME.EMBEDOBJECT(1454, "", Attachment1, "Attachment")
MailDoc.CREATERICHTEXTITEM ("Attachment")
End If

' send e-mail !!!!
MailDoc.PostedDate = Now()

' if error in attachment or name of recipients
On Error GoTo errorhandler1

MailDoc.send 0, recipient

Set Maildb = Nothing
Set MailDoc = Nothing
Set attachME = Nothing
Set session = Nothing
Set EmbedObj1 = Nothing

MsgBox "Your E-mail has been sent sucessfully to " & tobox.value & (Chr(13)) & "That you for using this wonderful e-mail code"

Unload Me
Exit Sub
' setting up the error message
errorhandler1:

MsgBox "Incorrect name supplied or incorrect names supplied please re-type in the names," & _
"or your Lotus Notes has not opened correctly. Recommend you open up Lotus Notes" & _
"to ensure the application runs correctly and that a vaild connection exists"

End Sub

Private Function GetAttach() As String
Dim strFileFullPath As String

strFileFullPath = Application.GetOpenFilename("Xl Files (*.xls), *.xls")
If strFileFullPath = "False" Then Exit Function
GetAttach = strFileFullPath

End Function

Private Sub CommandButton2_Click()
Set Maildb = Nothing
Set MailDoc = Nothing
Set attachME = Nothing
Set session = Nothing
Set EmbedObj1 = Nothing

Unload Me

End Sub

Private Sub CommandButton3_Click()

' setting and attaching the work book
Attachment1 = GetAttach 'ThisWorkbook.Path + "/" + "Book1.xls"

attach.Text = Attachment1

End Sub

- Attachment is via a control button on the user form - the pathway is shown in a text box called attach - You don't need it but people like to see that something has actually happened so the text box simply displays the pathway - in my userform it's disabled so the pathway can't be played with just looked at.

Phil:tumble:

I received an e-mail request for this so thought I'll try and re-attach the spreadsheet.

Here is the latest version, code as above - Hopefully the attachment system is operational!!!

Phil

Recieved another request for spreadsheet - so will try an attach - Here goe's wish me luck.

Phil