Velden uit ontvangen e-mail automatisch toevoegen aan Access database

Status
Niet open voor verdere reacties.
C

Cuyff

Nieuwe gebruiker
Lid geworden
15 feb 2010
Berichten
2
Hallo allemaal,

Ik ben op zoek naar een mogelijkheid om velden uit een e-mailbericht automatisch toe te voegen aan een tabel in Access.

Het gaat om bevestigingsmails van een formulier dat op een website staat. Wanneer dit formulier wordt ingevuld ontvang ik een e-mail in outlook (via een regel worden al deze mails in een aparte map geplaatst) met de inhoud zoals die in de bijlage te zien is.

Wat ik zou willen is dat de ingevulde gegevens op een eenvoudige manier toegevoegd worden aan een tabel in Access. Dit hoeft niet perse automatisch te gebeuren wanneer de mail binnenkomt (zou ideaal zijn), maar met een simpele handeling de ontvangen mails synchroniseren zou handig zijn.

Ik heb geen toegang tot de architectuur van de website en ben een beginner op het gebied van Access, vandaar dat ik de vraag hier maar even drop.

Op google vind ik alleen informatie over de mogelijkheid om vanuit Access een formulier te mailen waarvan dan automatisch een eventuele reactie verwerkt wordt in de database (The Collect data through e-mail messages Wizard) maar dat is dus niet de functionaliteit die ik zoek.

Bedankt!
 

Bijlagen

  • voorbeeld.jpg
    voorbeeld.jpg
    37,7 KB · Weergaven: 60
Cuyff zei:
... en ben een beginner op het gebied van Access, vandaar dat ik de vraag hier maar even drop.
Klik om te vergroten...
Fijn :D. Dat is een hele lastige klus, want als je geen toegang hebt tot het formulier, moet je het doen met de tekst uit de mail. Ik heb toevallig dit jaar een macro gemaakt die een mailbox met ingevulde formulieren uitleest, dus de techniek kan ik je wel laten zien. Maar dit moet echt geprogrammeerd worden... En als je dat niet zelf kunt, dan zou ik daar iemand voor inhuren. Een paar stukjes van de code, zodat je zelf wel kunt beoordelen of je dat kunt nabouwen.

Code: 
Function MailInlezen()
' Variabelen declareren
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Folder As Outlook.Folder
Dim Item As Outlook.MailItem
Dim Atmt As Outlook.Attachment
Dim cnt As String
Dim FileName As String, FileImport As String, tmpFileImport As String, Pad As String, tmpFile As String
Dim Mapje As String, SolNum As String
Dim i As Integer, iCount As Integer, iToe As Integer, iX As Integer, iArr As Integer
Dim arr As Variant
Dim tempi

On Error GoTo SaveAttachmentsToFolder_err
    '-------------------------------------------------------------------------------------------
    'Pad voor bestanden. Map wordt aangemaakt als hij niet bestaat.
    '-------------------------------------------------------------------------------------------
    Pad = "H:\Sollicitaties\" & Format(Date, "yyyy") & "\"
    On Error GoTo DirMaken
    Pad = PickFolder(Pad)

ChangeFolder:
    ChDir (Pad)

    Set DestWB = Workbooks(WerkBoek)
    Set Overzicht = DestWB.Sheets(WerkBlad)
    
    '-------------------------------------------------------------------------------------------
    'Met Late binding een Outlook sessie openen.
    '-------------------------------------------------------------------------------------------
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    
    On Error GoTo 0
    '-------------------------------------------------------------------------------------------
    ' De variabele Folder instellen op de standaard postbus
    '-------------------------------------------------------------------------------------------
    Set olNs = olApp.GetNamespace("MAPI")
    Set Folder = olNs.PickFolder
    'Voorbeeld van uitlezen van toegevoegde postbus
    ''Set Folder = olNs.Folders("Naam van de postbus").Folders("Postvak in").Folders("Sollicitaties")
    'Voorbeeld van uitlezen van mailfolder in eigen postbus
    ''Set Folder = olNs.GetDefaultFolder(olFolderInbox).Folders("Sollicitaties") ' Early Binding
    ''Set Folder = olNs.GetDefaultFolder(6).Folders("Sollicitaties")             ' Late Binding

    '-------------------------------------------------------------------------------------------
    ' Controleer de Folder op mails en sluit af als er niets gevonden wordt.
    '-------------------------------------------------------------------------------------------
    i = 0
    If Folder.Items.Count = 0 Then
        MsgBox "Er zijn geen sollicitaties in de folder " & Folder.Name & " gevonden.", vbInformation, "Niets gevonden"
        Exit Function
    End If
    
    iCount = Folder.Items.Count
    i = iCount - 1
    
    '-----------------------------------------------------------------------------------------
    ' Door alle mails lopen en uitlezen. Bijlagen opslaan in aparte map.
    '-----------------------------------------------------------------------------------------
    For Each Item In Folder.Items
        cont = Split(Item.Body, vbCrLf)
        arr = cont
        myArray = Overzicht.UsedRange
        
        '-------------------------------------------------------------------------------------
        ' Laatste rij vinden om records op te slaan.
        '-------------------------------------------------------------------------------------
        With Overzicht
            .Activate
            LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        End With
        Cells(LastRow, 1).Select

        '-------------------------------------------------------------------------------------
        ' Door array lopen om startpositie te vinden.
        '-------------------------------------------------------------------------------------
        For i = LBound(arr) To UBound(arr)
            If LCase(Left(arr(i), 26)) = "solliciteren bij amsterdam" Then
                iRij = i + 1
                Exit For
            End If
        Next

        On Error Resume Next
        
        '-------------------------------------------------------------------------------------
        ' Sollicitatienummer in werkblad zetten.
        '-------------------------------------------------------------------------------------
        Cells(LastRow + 1, 1) = arr(iRij)
        x = 1
        SolNum = arr(iRij)
        
        '-------------------------------------------------------------------------------------
        ' Eerste blok naamgegevens uitlezen. Tussenvoegsel elimineren.
        '-------------------------------------------------------------------------------------
        For i = 3 To 8 Step 2
            iArr = i
            x = x + 1
            If LCase(Left(arr(i + 1), 13)) = "tussenvoegsel" Then
                Cells(LastRow + 1, x) = StrConv(arr(iArr), vbProperCase) & ", " _
                    & LCase(arr(iArr + 2))
                iArr = iArr + 2
            Else
                If i = 3 Then
                    Cells(LastRow + 1, x) = UCase(arr(iArr))
                Else
                    Cells(LastRow + 1, x) = StrConv(arr(iArr), vbProperCase)
                End If
            End If
        Next i
        
            
        '-------------------------------------------------------------------------------------
        ' Bullets uitlezen.
        '-------------------------------------------------------------------------------------
        x = x + 1
        iArr = iArr + 3
        Cells(LastRow + 1, x) = StrConv(arr(iArr), vbProperCase)
        
        '-------------------------------------------------------------------------------------
        ' Geboortedatum uitlezen.
        '-------------------------------------------------------------------------------------
        If LCase(Left(arr(iArr + 2), 13)) = "geboortedatum" Then
            x = x + 1
            iArr = iArr + 3
            Cells(LastRow + 1, x) = arr(iArr)
            iArr = iArr + 3
        Else
            x = x + 1
            iArr = iArr + 4
        End If

        '-------------------------------------------------------------------------------------
        ' Adresgegevens 1 uitlezen. Straat, Huisnummer + toevoeging
        '-------------------------------------------------------------------------------------
        iArr = iArr + 3
         For i = (iArr) To (iArr + 2) Step 2
            x = x + 1
            ''iArr = iArr + 2
            If LCase(arr(i - 1)) = "huisnummer" Then
                If LCase(arr(i + 1)) = "huisnummer toevoeging" Then
                    Cells(LastRow + 1, x) = arr(i) & ", " & UCase(arr(i + 2))
                    iArr = iArr + 2
                Else
                    Cells(LastRow + 1, x) = StrConv(arr(i), vbProperCase)
                End If
            ElseIf LCase(arr(i - 1)) = "huisnummer toevoeging" Then
            Else
                Cells(LastRow + 1, x) = StrConv(arr(i), vbProperCase)
            End If
        Next i
        
        '-------------------------------------------------------------------------------------
        ' Adresgegevens 2 uitlezen. Woonplaats, Postcode, Email, Telefoon
        '-------------------------------------------------------------------------------------
        iArr = iArr + 4
         For i = (iArr) To (iArr + 7) Step 2
            x = x + 1
            Cells(LastRow + 1, x) = StrConv(arr(i), vbProperCase)
        Next i
        
        '-------------------------------------------------------------------------------------
        ' Bijlagen uitlezen
        '-------------------------------------------------------------------------------------
        iArr = iArr + 3
        For i = iArr To iArr + 2 Step 2
            On Error Resume Next
            x = x + 1
            Cells(LastRow + 1, x) = StrConv(arr(i), vbProperCase)
        Next i
        
        '-------------------------------------------------------------------------------------
        'Medium vraag (facultatief) LET OP i WAARDE!!!
        '-------------------------------------------------------------------------------------
        iArr = i + 1
        If LCase(Left(arr(iArr - 2), 15)) = "via welk medium" Then
            x = x + 1
            Cells(LastRow + 1, x) = StrConv(arr(iArr), vbProperCase)
        End If
   
        '-------------------------------------------------------------------------------------
        ' Bijlagen opslaan in eigen map met naam sollicitant
        '-------------------------------------------------------------------------------------
        For Each Atmt In Item.Attachments
            iToe = 0
            Mapje = Pad & IIf(Right(Pad, 1) <> "\", "\", "") & SolNum & "\" & arr(7) & "\"
            On Error GoTo MapPersoon

PersoonMapGemaakt:
            If Dir(Mapje, vbDirectory) & "" = "" Then CreateDir (Mapje)
            FileName = Mapje & Atmt.FileName
            '-----------------------------------------------------------------------------
            'Eerst controleren of het importbestand al in de map Import staat...
            '-----------------------------------------------------------------------------
            tmpFile = Dir(FileName)
            If tmpFile & "" = "" Then
                '-------------------------------------------------------------------------
                'Bestand is nog niet opgeslagen; opslaan.
                '-------------------------------------------------------------------------
                Atmt.SaveAsFile FileName
            Else
                '-------------------------------------------------------------------------
                'Bestand(snaam) bestaat al; opslaan onder een nieuwe naam.
                '-------------------------------------------------------------------------
                iToe = iToe + 1
                tmp = Split(tmpFile, ".")
                FileName = ""
                For i = LBound(tmp) To UBound(tmp) - 1
                    If Not FileName = "" Then FileName = FileName & "."
                    FileName = FileName & tmp(i)
                Next i
                FileName = FileName & "_" & iToe & "." & tmp(UBound(tmp))
                Atmt.SaveAsFile Mapje & FileName
            End If
        Next Atmt
    Next Item

' Maak het geheugen leeg
SaveAttachmentsToFolder_exit:
    Set olNs = Nothing
    Set olApp = Nothing
    Set Atmt = Nothing
    Set Item = Nothing
    Set NS = Nothing
    
    Exit Function

SaveAttachmentsToFolder_err:
'----------------------------------------------------------
' Foutverwerking
'----------------------------------------------------------
    MsgBox "Er is een fout opgetreden." & vbCrLf _
        & "Error Nummer: " & Err.Number & vbCrLf _
        & "Error omschrijving: " _
        & Err.Description, vbCritical, "Foutje!"
    Resume SaveAttachmentsToFolder_exit

DirMaken:
'----------------------------------------------------------
'Nieuwe map maken als hij nog niet bestaat
'----------------------------------------------------------
    Call CreateDir(Pad)
    GoTo ChangeFolder

MapPersoon:
    Call CreateDir(Pad)
    GoTo PersoonMapGemaakt
End Function

En dat is dan nog maar een deel van het verhaal... Zal ook vast wel korter kunnen, maar met een beetje mazzel kijken de Excel specialisten niet mee :).
Wat het voor jou iets makkelijker maakt, is dat het wegschrijven steeds naar een nieuw record moet, en dat is dus in Access veel makkelijker te regelen. Maar uit uitlezen van de mail zelf, dat blijft dus lastig.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan