Mas ele funcionou apenas uma vez, e nunca mais.
Já conferi linha por linha, li mil tutoriais. Está tudo certo.
Copiei o código para o Excel e funciona perfeitamente. Só no Outlook que não.
As referências estão Ok, o VBA não retorna erro nenhum...
Simplesmente ele não executa a parte do código que coloquei em vermelho.
Onde eu estou errando, pelamordedeus?
Código: Selecionar todos
Módulo de Classe: ClasseConexao
Public Conn As New ADODB.Connection
Public Sub Conectar()
Dim nConectar As String
Dim PastaArq As String
Dim CaminhoArq As String
'local do banco de dados
PastaArq = "C:\Users\37365\Desktop\"
If (Right(PastaArq, 1) <> "\") Then
PastaArq = PastaArq & "\"
End If
'Local e nome do banco de dados
CaminhoArq = PastaArq & "base.accdb"
nConectar = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & CaminhoArq
Conn.ConnectionString = nConectar
Conn.Open
End Sub
Public Sub Desconectar()
Conn.Close
End Sub
Código: Selecionar todos
ThisOutlookSession:
Public Sub SalvarAnexo(Item As MailItem)
Dim Atmt As Attachment
Dim FileName As String
'verificar extensao do anexo
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 4) = "xlsm" Then
FileName = "C:\temp\" & Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
End If
If Right(Atmt.FileName, 4) = "xlsx" Then
FileName = "C:\temp\" & Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
End If
If Right(Atmt.FileName, 3) = "xls" Then
FileName = "C:\temp\" & Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Dim xlApp As Excel.Application
Set xlApp = New Excel.Application
xlApp.DisplayAlerts = False
xlApp.Workbooks.Open (FileName)
Dim xlSht As Excel.Worksheet
Set xlSht = xlApp.Sheets(1)
Dim xlRng As Excel.Range
Set xlRng = xlSht.Cells(1, 8)
Dim ndia As String
Dim nsetor As String
Dim nnome As String
Dim ndestino As String
Dim nsaida As String
Dim nretorno As String
Dim ndetalhes As String
Dim cadem As String
Dim cadpor As String
Dim rFirst As Long
Dim rLast As Long
Dim x As Integer
'verificar se o arquivo contem o codigo verificador
Select Case xlSht.Cells(1, 8).Value
Case "se2213evertonmonteiro"
'definir a primeira e a ultima linhas que contém registros na planilha
rLast = xlSht.Cells(Rows.Count, "A").End(xlUp).Row
If xlSht.Cells(466, 2).Value = 0 Then
rFirst = "384"
Else
rFirst = "467"
End If
'executar a ação X a cada registro da planilha
For x = rFirst To rLast
ndia = xlSht.Cells(x, "A").Value
nsetor = xlSht.Cells(x, "B").Value
nnome = xlSht.Cells(x, "D").Value
ndestino = xlSht.Cells(x, "E").Value
nsaida = xlSht.Cells(x, "F").Value
nsaida = Format(nsaida, "hh:nn")
nretorno = xlSht.Cells(x, "G").Value
nretorno = Format(nretorno, "hh:nn")
ndetalhes = xlSht.Cells(x, "H").Value
cadem = Item.ReceivedTime
cadpor = Item.SenderName
'chamar a Classe Conexao
Dim cx As New ClasseConexao
'VARIÁVEL DE ARMAZENAMENTO DOS DADOS DO BANCO
Dim banco As ADODB.Recordset
'VARIÁVEL DE COMANDO PARA INSERIR OD DADOS
Dim sql As String
'DEFININDO INSTRUÇÃO A VARIÁVEL
sql = "INSERT INTO [atendimentos]( dia, nome, setor, prev_saida, prev_retorno, detalhes)"
sql = sql & " VALUES ( "
sql = sql & "#" & ndia & "#, "
sql = sql & "'" & nnome & "', "
sql = sql & "'" & nsetor & "', " 'INSERT INTO , INSTRUÇÃO SQL PARA INSERIR DADOS
sql = sql & "#" & nsaida & "#, "
sql = sql & "#" & nretorno & "#, "
sql = sql & "'" & ndetalhes & "')"
Set banco = New ADODB.Recordset
'CONECTAR AO BANCO DE DADOS
cx.Conectar
'EXECUTAR A SQL
[color=#FF0000][b]banco.Open sql, cx.Conn[/b]
'DESCONECTAR PARA LIBERAR MEMÓRIA
cx.Desconectar
Next x
Case Else
Exit Sub
End Select
Next Atmt[/color]
End Sub