Vídeo recomendado
https://youtu.be/diWPPPhW-9E

[ADO] Outlook → BD do Access

tonn3r
Acabou de chegar
Acabou de chegar
Mensagens: 1
Registrado em: Qua Mar 27, 2013 10:54 am

[ADO] Outlook → BD do Access

Mensagem por tonn3r »

Montei o código de DAO para lançar registros no Access, de acordo com anexos que chegam pelo outlook.

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? :cry:


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


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder