Hoje vou mostrar como baixar anexos de e-Mail via AdvPL.
Algumas vezes, temos a necessidade de fazer importações de arquivos que chegam através de e-Mails.
Seja arquivos xml ou txt, via AdvPL é possível fazer o download diretamente da caixa de entrada. Para isso, basta instanciar a classe tMailManager, passando os dados de acesso ao provedor de e-Mail.
Em seguida, ler o conteúdo dos e-Mails e quando tiver um anexo, baixar o arquivo para dentro da Protheus Data, e depois movê-lo de pasta do provedor (se for IMAP).
Para ilustrarmos o cenário comentado, abaixo o código fonte desenvolvido:
//Bibliotecas
#Include "Protheus.ch"
#Include "RWMake.ch"
#Include "Ap5Mail.ch"
Static nVez := 2 //Se for caixas no hotmail.com / outlook.com, deve-se rodar a rotina duas vezes seguidas, pois ele não consegue "mover" de pasta na primeira vez
/*/{Protheus.doc} zBxMail
Função para buscar anexos de e-Mails da Locaweb / Uol
@author Atilio
@since 27/09/2018
@version 1.0
@type function
@obs Abaixo algumas observacoes:
1 - Essa funcao utiliza a classe tMailManager com contas IMAP, mas tambem e possivel utilizar com POP
2 - Se for uma conta em hotmail.com / outlook.com, deve-se rodar a rotina duas vezes seguidas, pois ele não consegue "mover" de pasta na primeira vez
Portanto, se estiver usando dessa forma, altere a variavel nVez para 1, para que assim ele execute "2 vezes"
3 - Essa rotina baixa emails para a pasta \x_importacao\ dentro da Protheus Data, porem voce pode configurar para outros diretorios, dentro da Protheus Data
4 - O download e feito a partir da linha 184, onde nesse exemplo e efetuado download de qualquer txt vindo por email, mas e possivel aplicar outros filtros
com os atributos do objeto oMessage
/*/
User Function zBxMail()
Local cArqSem := "\x_importacao\semaforo_email.lck"
Private lJobPvt := .F.
If nVez <= 2
//Alert("zBxMail - Processo iniciado - "+Time())
//Se não tiver aberto o dicionário (rotina executada sem abrir o Protheus)
If Select("SX2") <= 0
RPCClearEnv()
RPCSetEnv("01","","","","","")
lJobPvt := .T.
Else
If ! MsgYesNo("Deseja acessar a caixa de entrada e baixar os arquivos TXT?", "Atenção")
Return
EndIf
EndIf
//Se existir o semáforo, dá mensagem de erro
If File(cArqSem)
//Alert("zBxMail - Semáforo existente (" + MemoRead(cArqSem) + ") - "+Time())
//Mostrando mensagem
If ! lJobPvt
Aviso("Atenção", "Semáforo existente (Processo iniciado em " + MemoRead(cArqSem) + ")")
EndIf
Else
//Chamando o processamento de dados
Processa({|| fProcessa() }, "Processando...")
//Mostrando mensagem de conclusão
If ! lJobPvt
Aviso("Atenção", "Processo concluído.")
EndIf
FErase(cArqSem)
EndIf
//Atilio, 27/02/2019, para caixas Hotmail, rodar 2x para mover de pasta
nVez++
u_zBxMail()
EndIf
//Alert("zBxMail - Processo finalizado - "+Time())
Return
/*---------------------------------------------------------------*
| Func.: fProcessa |
| Desc.: Função de processamento para buscar os arquivos |
*---------------------------------------------------------------*/
Static Function fProcessa()
Private cDirBase := GetSrvProfString("RootPath", "")
Private cDirPad := "\x_importacao\"
Private cConta := ''
Private cSenha := ''
Private cSrvFull := ''
Private cServer := ''
Private nPort := 0
//Definindo dados da conta
cConta := "email@empresa.com.br"
cSenha := "Sua Senha XXX"
cSrvFull := "servidor.com.br:993"
cServer := Iif(':' $ cSrvFull, SubStr(cSrvFull, 1, At(':', cSrvFull)-1), cSrvFull)
nPort := Iif(':' $ cSrvFull, Val(SubStr(cSrvFull, At(':', cSrvFull)+1, Len(cSrvFull))), 110)
//Se o último caracter não for barra, retira ela
If SubStr(cDirBase, Len(cDirBase), 1) == '\'
cDirBase := SubStr(cDirBase, 1, Len(cDirBase)-1)
EndIf
//O diretório cheio, será o caminho absoluto + conteúdo do parâmetro, por exemplo, D:\TOTVS\TOTVS Protheus\Protheus_Data\x_importacao_email
cDirFull := cDirBase + cDirPad
//Chama a importação
fBaixa()
Return
/*---------------------------------------------------------------*
| Func.: fBaixa |
| Desc.: Função que baixa as mensagens do e-Mail |
*---------------------------------------------------------------*/
Static Function fBaixa()
Local aArea := GetArea()
Local cArqINI
Local cBkpConf
Local nRet
Local nNumMsg
Local nMsgAtu
Local oManager
Local oMessage
Local nAnexoAtu
Local nTotAnexo
Local aInfAttach
Local lOk
Local lEntrou
//Altera o arquivo appserver.ini, deixando como IMAP
cArqINI := GetSrvIniName()
cBkpConf := GetPvProfString( "MAIL", "Protocol", "", cArqINI )
WritePProString('MAIL', 'PROTOCOL', 'IMAP', cArqINI)
//Cria a conexão base no gerenciamento
oManager := tMailManager():New()
oManager:SetUseSSL(.T.)
oManager:SetUseTLS(.T.)
oManager:Init(cServer, "", cConta, cSenha, nPort, 0)
//Caso não consiga setar 120 segundos como timeout (2 minutos), não continua
If oManager:SetPopTimeOut(120) != 0
//Alert("zBxMail - Falha ao setar o timeout" )
Else
//Faz a conexão com IMAP
nRet := oManager:IMAPConnect()
//Se não conseguir conectar, mostra qual é a mensagem de erro
If nRet != 0
//Alert("zBxMail - Falha ao conectar" )
//Alert("zBxMail - ERROR - " + StrZero(nRet, 6), oManager:GetErrorString(nRet))
Else
//Alert("zBxMail - Sucesso ao conectar" )
//Busca o número de mensagens na caixa de entrada
nNumMsg := 0
oManager:GetNumMsgs(@nNumMsg)
//Se houver mensagens a serem processadas
If nNumMsg > 0
ProcRegua(nNumMsg)
//Percorre o número de mensagens
For nMsgAtu := 1 To nNumMsg
IncProc("Baixando e-Mail " + cValToChar(nMsgAtu) + " de " + cValToChar(nNumMsg) + "...")
//Buscando a mensagem atual
oMessage := tMailMessage():new()
oMessage:Clear()
oMessage:Receive(oManager, nMsgAtu)
//Busca o total de Anexos
nTotAnexo := oMessage:GetAttachCount()
//Limpando a flag
lOk := .T.
lEntrou := .F.
//Percorre todos os anexos
For nAnexoAtu := 1 To nTotAnexo
//Busca as informações do anexo
aInfAttach := oMessage:GetAttachInfo(nAnexoAtu)
//Se tiver conteúdo, e for do tipo TXT
If ! Empty(aInfAttach[1]) .And. Upper(Right(AllTrim(aInfAttach[1]),4)) == '.TXT' //.And. "REMETENTE" $ Upper(oMessage:cFrom)
lEntrou := .T.
//Salva o arquivo na pasta correta
If oMessage:SaveAttach(nAnexoAtu, cDirFull + aInfAttach[1])
//Alert("+================================+")
//Alert("zBxMail - e-Mail Lido com Anexo: ")
//Alert("e-Mail Origem: " + cConta)
//Alert("Número da Mensagem: " + cValToChar(nMsgAtu))
//Alert("De: " + oMessage:cFrom)
//Alert("Cópia: " + oMessage:cCc)
//Alert("Assunto: " + oMessage:cSubject)
//Alert("Número Anexo: " + cValToChar(nAnexoAtu))
//Alert("Anexo " + StrZero(nAnexoAtu, 3) + ": " + aInfAttach[1] )
//Alert("Corpo: " + oMessage:cBody)
//Alert("+================================+")
Else
lOk := .F.
//Alert("zBxMail - Erro ao salvar anexo " + cValToChar(nAnexoAtu) + ": " + aInfAttach[1] )
EndIf
EndIf
Next nAnexoAtu
//Se o anexo tiver sido salvo com sucesso
If lOk
If lEntrou
If ! (oManager:MoveMsg(nMsgAtu, "Importados"))
//Alert("zBxMail - Não foi possível mover a mensagem - " + cValToChar(nMsgAtu) + "...")
EndIf
Else
If ! (oManager:MoveMsg(nMsgAtu, "Processados"))
//Alert("zBxMail - Não foi possível mover a mensagem - " + cValToChar(nMsgAtu) + "...")
EndIf
EndIf
EndIf
//Alert(CRLF)
Next nMsgAtu
Else
//Alert("zBxMail - Não existem mensagens para processamento...")
EndIf
//Desconecta do servidor IMAP
oManager:IMAPDisconnect()
EndIf
EndIf
//Volta a configuração de Protocol no arquivo appserver.ini
WritePProString('MAIL', 'PROTOCOL', cBkpConf, cArqINI)
RestArea(aArea)
Return
Bom pessoal, por hoje é só.
Abraços e até a próxima.
