[Resolvido]Abrindo e Copiando Emails

Olá Pessoal,

Procurei no Fórum Algo sobre abrir emails e trabalhar com os dados no Access, há um assunto com o mestre Vieira, mas a mensagem parece que foi truncada só ficando os comentarios do Mestre. Gostaria de pediar aos colegas se alguem tiver alguma sugestão para responder. Pensei no seguinte:
Configurar Varias contas de e-mail no outlook e salvar as mensagens em uma determinada pasta, para depois vincular esta pasta no access e poder visualizar as mensagens.
Obrigado

Experimente do Mestre Jpaulo para um colega em outro fórum


Public Function Outlook_Contacts_2_Access()


On Error GoTo No_Bugs


Dim CnnA As ADODB.Connection
Dim goRs As ADODB.Recordset


Dim oApp As Outlook.Application
Dim oNS As Outlook.NameSpace

Dim oInbox As Outlook.MAPIFolder

Dim oEmail As Outlook.MailItem


Dim i As Integer



Set oApp = New Outlook.Application

Set oNS = oApp.GetNamespace("MAPI")

Set oInbox = oNS.GetDefaultFolder(olFolderInbox)



Dim sSQL As String



Set CnnA = New ADODB.Connection

Set goRs = New ADODB.Recordset

'YOU WILL NEED TO CREATE YOUR TABLE IN ACCESS TO MATCH AND CALL IT INBOX

sSQL = "SELECT * FROM [Inbox] WHERE 1=2;"

goRs.Open sSQL, CnnA, adOpenKeyset, adLockOptimistic, adCmdText



frmMain.prbProgress.Max = oInbox.Items.Count

i = 1

Do While i <= oInbox.Items.Count

Set oEmail = oInbox.Items(i)

DoEvents

goRs.AddNew

goRs!To = oEmail.To

goRs!CC = oEmail.CC

goRs!BCC = oEmail.BCC

goRs!Subject = oEmail.Subject

goRs!Body = oEmail.Body
goRs!HTMLBody = oEmail.HTMLBody

goRs!Importance = oEmail.Importance

goRs!Received = oEmail.ReceivedTime

goRs!MessageClass = oEmail.MessageClass 'EMAIL, MEETING RESPONSE, MEETING REQUEST, ETC.

goRs!ReceivedByName = oEmail.ReceivedByName

'CONTINUE ON WITH OTHER FIELDS YOU WANT

'...
goRs.Update

Set oEmail = Nothing

frmMain.prbProgress.Value = i

i = i + 1

Loop

Set oEmail = Nothing

Set oInbox = Nothing

Set oNS = Nothing

goRs.Close
Set CnnA = Nothing

Set goRs = Nothing

Exit Function

No_Bugs:



MsgBox Err.Number & "-" & Err.Description, vbCritical, "Outlook Email Export"

Resume Next

End Function


Em alternativa experimente também esse


Option Compare Database
Option Explicit

Dim oApp As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oWindow As Object
Dim omail As Outlook.MailItem

Private Sub Comando12_Click()

Set oApp = New Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oWindow = oApp.ActiveWindow
Set omail = oApp.ActiveExplorer.Selection.Item(1)

txt_remetente = omail.SenderName 'Remetente
txt_cc = omail.CC 'Com cópia
txt_assunto = omail.Subject 'Assunto
txt_mensagem = omail.Body 'Mensagem
txt_para = omail.To 'Destinatário
txt_data = omail.ReceivedTime

End Sub

Olá Vieira,

Vou testar e darei retorno, Boa Noite
E até breve.

Abraços Gerson

Olá Vieira,

Amigo tive dificuldade de implementar o exemplo do Jpaulo, no entanto no meu caso consegui através do assistente vincular a Pasta no Outlook as quais os emails são recebidos, satisfazendo assim minhas necessidades.
Esse assunto darei como encerrado,obrigado e até a próxima.

Abraços,

Gentileza colocar sempre o Resolvido, clicando no botão apropriado.

Foi pena não ter experimentado o outro código, mas se resolveu o problema tudo OK.

Olá, Pessoal

Peço desculpas por não ter finalizado o tópico.
Obrigado pela força.

Abraços Gerson.