Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Copiar valor de cél...
 
Notifications
Clear all

Copiar valor de célula e colar em e-mail Lotus Notes

 
2024 - VBA & Macros
4 Posts
2 Usuários
0 Reactions
1,032 Visualizações
RSS
 Ana Carolina Toledo
(@ana-carolina-toledo)
Posts: 11
Eminent Member
Topic starter
 

Boa tarde pessoal,

Tenho um códio que envia e-mail com anexo através do Lotus Notes porém eu não consigo copiar o valor de uma célula X e copiar no body do email como uma imagem.

Alguém sabe se isso é possível? Caso sim, teriam o código?

Obrigada

Segue o código (o excel encontra-se anexado): 

'Set up the objects required for Automation into lotus notes
Dim Maildb As Object 'The mail database
Dim UserName As String 'The current users notes name
Dim MailDbName As String 'THe current users notes mail database name
Dim MailDoc As Object 'The mail document itself
Dim AttachME As Object 'The attachment richtextfile object
Dim Session As Object 'The notes session
Dim EmbedObj As Object 'The embedded object (Attachment)
Dim stSignature As String

Sub Envia_Email()

'Start a session to notes
Set Session = CreateObject("Notes.NotesSession")
'Get the sessions username and then calculate the mail file name
'You may or may not need this as for MailDBname with some systems you
'can pass an empty string
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
'Open the mail database in notes
Set Maildb = Session.GETDATABASE("", MailDbName)
If Maildb.IsOpen = True Then
'Already open for mail
Else
Maildb.OPENMAIL
End If
'Set up the new mail document
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"

'Attach Your Signature '<------
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)

'MailDoc.Recipient = Recipient
'Addressee = ""
Addressee = "toledo.carolina@gmail.com"
Recipient = Split(Addressee, ",")
MailDoc.sendto = Recipient

'MailDoc.Recipient = CopyTo
'MailDoc.copyto = ""

'MailDoc.Recipient = BlindCopyTo
'MailDoc.blindcopyto = ""

'MailDoc.Subject = Subject
MailDoc.Subject = "teste notes"
'MailDoc.Body = BodyText
MailDoc.Body = "Hello, This is a test" & vbCrLf & vbCrLf & stSignature
'MailDoc.SAVEMESSAGEONSEND = SaveIt
MailDoc.SAVEMESSAGEONSEND = True

'Set up the embedded object and attachment and attach it
Attachment = "C:UsersUser_adminDesktopDummy.txt"
If Attachment <> "" Then
Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "Attachment")

End If
'Send the document
MailDoc.SEND 0, Recipient
'Clean Up
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing

End Sub
 
Postado : 08/10/2012 1:58 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa noite!!

Por favor leia as regras do fórum!!
Os arquivos devem ser compactados!!!

Nossas Regras
viewtopic.php?f=7&t=203

Att

 
Postado : 08/10/2012 3:11 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

tenho um exemplo na empresa... amanhã coloco para você testar

 
Postado : 15/10/2012 6:21 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Segue codigo :

Function SendMailTarcisio()


On Error GoTo SendMailError

Plan13.Visible = xlSheetVisible
Sheets("dados").Select
    Range("B1").Select


EMailSendTo = Cells(31, 2).Value '"geronimo_andrzejewski@embraco.com" '' Required - Send to address
EMailCCTo = Cells(32, 2).Value                     '' Optional
EMailBCCTo = Cells(33, 2).Value                     '' Optional
EmailSubject = Cells(34, 2).Value


''Establish Connection to Notes
Set objNotesSession = CreateObject("Notes.NotesSession")

''Establish Connection to Mail File
''                                    .GETDATABASE("SERVER", "FILE")
Set objNotesMailFile = objNotesSession.GetDatabase("", "")
''Open Mail
objNotesMailFile.OPENMAIL

''Create New Memo
Set objNotesDocument = objNotesMailFile.CreateDocument

''Create 'Subject Field'
Set objNotesField = objNotesDocument.AppendItemValue("Subject", EmailSubject)

''Create 'Send To' Field
Set objNotesField = objNotesDocument.AppendItemValue("SendTo", EMailSendTo)

''Create 'Copy To' Field
Set objNotesField = objNotesDocument.AppendItemValue("CopyTo", EMailCCTo)

''Create 'Blind Copy To' Field
Set objNotesField = objNotesDocument.AppendItemValue("BlindCopyTo", EMailBCCTo)

''Create 'Body' of memo
Set objNotesField = objNotesDocument.CreateRichTextItem("Body")

With objNotesField
    
    .AppendText = Cells(35, 2).Value
    .AddNewLine 1
    .AppendText Cells(36, 2).Value
    .AddNewLine 3
    .AppendText Cells(37, 2).Value
    .AddNewLine 1
    .AppendText Cells(38, 2).Value
    .AddNewLine 1
    .AppendText Cells(39, 2).Value
    
End With

'Anexar planilha no email --- 1454 indica um anexo de arquivo
''objNotesField = objNotesField.EMBEDOBJECT(1454, "", "C:Temptest.xls")
'objNotesField = objNotesField.EmbedObject(1454, "", ActiveWorkbook.FullName)


''Enviar o emaill
objNotesDocument.Send (0)

''Release storage
Set objNotesSession = Nothing
Set bjNotesSession = Nothing
Set objNotesMailFile = Nothing
Set objNotesDocument = Nothing
Set objNotesField = Nothing

''Set return code
SendMailTeste = True

Plan13.Visible = xlSheetHidden
Sheets("Plan1").Select
    Range("a5").Select



Exit Function

SendMailError:
Msg = "Error # " & Str(Err.Number) & " was generated by " _
           & Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext

SendMailTeste = False


End Function
 
Postado : 16/10/2012 4:33 am
Forum Jump:
  Tópico Anterior
Próximo Tópico