Incluir compromisso e anexo em conta do Outllook Externo

[miranda.flavio]

Pessoal,
Boa noite,
Recentemente inclui em meus projetos, excel VBA, a funcionalidade de envio de um determinado range da planilha e um arquivo anexo para uma conta de email externa. No entanto tenho a intenção de acompanhar a resposta deste email, e ai esta meu problema....... Nesse blog, no qual tem otimos conteudos, encontrei um conteudo show de bola, disponibilizado e comentado pelo Tomás Vásquez, que utilizando recursos em VBA inseri compromisso e tarefa no outlook. Assim gostaria de saber do pessoal do forum se alguem ja integrou no codigo abaixo o envio de compromisso para uma conta de email externa.
Anexo a planilha disponibilizada pelo Tomás, Abraços


Private Sub Insere_Compromisso_Outlook()
On Error GoTo Add_Err

Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim objRecurPattern As Outlook.RecurrencePattern
Set objOutlook = CreateObject("Outlook.Application")
Set objAppt = objOutlook.CreateItem(olAppointmentItem)
With objAppt
.Start = #7/16/2010 3:00:00 PM#
.End = #7/17/2010 4:00:00 PM#
.Duration = 30 'duração em minutos
.Subject = "Título da tarefa"
.Body = "Notas / corpo da tarefa"
.Location = "Local da tarera"
'Seta o comprimisso para ser lembrado
.ReminderMinutesBeforeStart = 15 'tempo em minutos
.ReminderSet = True

Set objRecurPattern = .GetRecurrencePattern
'Seta a recorrência da tarefa
'Exclua estas linhas caso não queira uma tarefa recorrente
With objRecurPattern
.RecurrenceType = olRecursWeekly
.Interval = 1
'Uma vez por semana
.PatternStartDate = #7/16/2010#
.PatternEndDate = #7/17/2010#
End With
.Save
.Close (olSave)
End With

Set objAppt = Nothing

Set objOutlook = Nothing
Set objRecurPattern = Nothing
MsgBox "Compromisso inserido com sucesso!"
Exit Sub
Add_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub

[webmaster]

Flavio,

Se entendi bem, a esse código você quer adicionar o convite de outros emails a este compromisso?

Abraços

[miranda.flavio]

Tomás,
Boa tarde...
Isso mesmo. A ação será do usuário, após clicar em um Botão de comando, enviar um compromisso para outra conta de email anexando ao corpo deste um range da planilha e um anexo.

Atualmente utilizo o código abaixo, união de dois códigos disponibilizado no blog, que envia o email para contas determinadas, anexa um arquivo e incorpora ao corpo do email o conteúdo de um range na pasta. Porém gostaria de inserir todas essas informações em diversas contas de email e como em um folow-up, administrar os compromissos. Desde já agradeço sua atenção. Abraços, Flavio

Sub Mail_Selection_Outlook_Body() 'nome anterior
'DEFININDO RELATORIO(RPE), SUA PASTA E SEU RESPECTIVO EMAIL(EM)
Sheets("RPE").Select
Dim EM(3) As String
Dim RPE(1) As String
'Site
RPE(1) = "RPE"
'EMAILs
EM(1) = "miranda.flavio@hotmail.com"
'EM(2) = "conta de email 2"
'EM(3) = "conta de email 3"

For i = 1 To 1
If RPE(i) = "" Then GoTo SAI

'PROGRAMAÇÃO DE ENVIO DA PASTA
'NO SEU PESPECTIVO CORPO DE EMAIL
Dim source As Range
Dim dest As Workbook
Dim myshape As Shape
Dim OutApp As Object
Dim OutMail As Object
Set source = Nothing
On Error Resume Next
Sheets(RPE(i)).Select
'COPIANDO E COLANDO VALORES
Range("B1:N63").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
'ESCREVENDO EM DETERMINADA CÉLULA
Range("B1").Select
ActiveCell.FormulaR1C1 = "texto 1 no corpo do email" & RPE(i)
Range("B2").Select
ActiveCell.FormulaR1C1 = "texto 2 no corpo do email"
Range("C5").Select
ActiveCell.FormulaR1C1 = "texto 3 no corpo do email"
'NEGRITO
Range("B1").Select
Selection.Font.Bold = True
'Range("A11").Select
'Selection.Font.Bold = True
'Range("A13").Select
'Selection.Font.Bold = True

Sheets(RPE(i)).Select
Range("B1:N63").Select
Set source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

'VERIFICAÇÕES DE POSSÍVEIS ERROS
If source Is Nothing Then
MsgBox "A planilha está vazia ou a Pasta está protegida" & _
vbNewLine & "Por favor, corrija e tentenovamente!!", vbOKOnly
Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
Selection.Cells.Count = 1 Or _
Selection.Areas.Count > 1 Then
MsgBox "Um Erro ocorrido:" & vbNewLine & vbNewLine & _
"Você tem mais de uma Pasta selecionada." & vbNewLine & _
"Houve um erro na seleção das células." & vbNewLine & _
"Ou a programação foi interrompida." & vbNewLine & vbNewLine & _
"Por favor, corrija e tentenovamente !!", vbOKOnly
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Copy
Set dest = ActiveWorkbook
For Each myshape In dest.Sheets(1).Shapes
myshape.Delete
Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = EM(i)
.CC = ""
.BCC = ""
.Subject = "Contratação Head Count " & RPE(i)
.HTMLBody = RangetoHTML
.Send
End With
dest.Close False
Set OutMail = Nothing
Set OutApp = Nothing
Set dest = Nothing
Application.ScreenUpdating = True
' MsgBox "Mensagem enviada!"
' limpar dados
Sheets(RPE(i)).Select
Range("A5:C200").Select
Selection.ClearContents
Range("A1").Select
Next

SAI:
MsgBox "Mensagem Enviada com Sucesso!!" & vbNewLine & vbNewLine & _
"Um Abraço," & vbNewLine & _
"Flávio Miranda", vbOKOnly
fim:
End Sub

Function RangetoHTML()
Dim fso As Object
Dim ts As Object
Dim TempFile As String
TempFile = ThisWorkbook.Path & "Site.htm" '"C:\\Temp\\Site.htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
source:=Selection.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function

[steferson]

Boa tarde poderiam por favor me ajudar com um passo a passo de como utilizar o codigo, entrar com as informações no excel