bijlagen van inkomende mail automatisch opslaan

Status
Niet open voor verdere reacties.
Andre175

Andre175

Gebruiker
Lid geworden
2 feb 2018
Berichten
351
hallo.

In deze vraag vond ik bijna de oplossing die ik zocht.

ik krijg mails met in de bijlage een factuur.
In het onderwerp staat dan bijvoorbeeld: "Factuur 12345 Firma X"
waarbij 12345 het factuurnummer is, en dus in iedere mail van Firma X anders is.

hieronder een deel van de code.

Code: 
Private Sub Items_ItemAdd(ByVal item As Object)
    On Error GoTo ErrorHandler
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then
        If LCase(item.Subject) = "[COLOR="#FF0000"]Factuur Firma X[/COLOR]" Then
            SaveSelectionAttachments
        End If
    End If


Als ik in de code het factuurnummer gewoon weglaat, zal het denk ik niet werken.
Zoals de code nu is, wordt er toch naar een exacte overeenkomst van het onderwerp gekeken?
Ik heb geprobeerd de volledige code toe te passen, maar er wordt niets opgeslagen.
De opslaglocatie elders in de code heb ik uiteraard ook aangepast.
 
Laatst bewerkt:
Goedemorgen Edmoor.

Uiteraard had ik gezocht op helpmij.nl,
Als je in #1 op het woordje "deze" klikt, kom je op hetzelfde uit als waar jij me op wijst.

Een zekere Edmoor heeft daar een mooie code neer gezet die zou moeten werken, een deel van die code heb ik eruit gehaald voor mijn vraag.;)
Uiteraard heb ik de gehele code geplaatst bij 'this outlook session'.
Code: 
If LCase(item.Subject) = "factuur firma x" Then

Ik zie dat ik in mijn vraag hoofdletters had gedaan, dit werd al aangegeven dat het kleine letters moesten zijn. dat heb ik wel.
Duid je op de hoofdletters met "klopt hier natuurlijk niks van"?

en nee, ik wist niet exact wat LCase doet.

( https://www.excelfunctions.net/vba-lcase-function.html )

Nu wordt er dus naar een exacte overeenkomst van het onderwerp gekeken.
Hoe kan er naar het onderwerp gekeken worden of het onderwerp een aantal woorden bevat?




André
 
Laatst bewerkt:
Code: 
If Instr(LCase(item.Subject), "factuur firma x",vbTextCompare) > 0 Then

Heb ik het zo goed begrepen, of moet ieder woord apart vergeleken worden?

Zoiets als....


Code: 
If Instr(LCase(item.Subject), "factuur",vbTextCompare) And  _
   Instr(LCase(item.Subject), "firma",vbTextCompare) And _
   Instr(LCase(item.Subject), "x",vbTextCompare) > 0 Then
 
Laatst bewerkt:
Bijna :)
Ik zou het zo doen:
Code: 
    If InStr(1, LCase(Item.Subject), "factuur", vbTextCompare) > 0 Or _
       InStr(1, LCase(Item.Subject), "firma", vbTextCompare) > 0 Or _
       InStr(1, LCase(Item.Subject), "x", vbTextCompare) > 0 Then
 
Dat de "1" een "0" moest zijn, zag ik ook net.... :d

Jij geeft "Or" aan, oftewel als 1 van de woorden voorkomt in het onderwerp.
dat kan natuurlijk ook, in mijn geval is het de bedoeling dat de facturen van verschillende crediteuren in de juiste map komen.
Dus niet alle facturen in dezelfde map, vandaar dat ik "And" gebruik.

Ik zal de code dus nog verder moeten uitbreiden zodat de opslaglocatie ook steeds aangepast wordt.


En Instr(1,...... deze 1 is toch een optie?
Als deze weg wordt gelaten dan staat deze standaard op 1.

https://www.excelfunctions.net/vba-instr-function.html
 
Laatst bewerkt:
Of je And of Or gebruikt is uiteraard afhankelijk an wat precies je bedoeling is, maar het gaat er maar om dat het gebruik van de Instr functie duidelijk is.
 
Uitzoeken hoe een bepaalde functie werkt is vaak niet zo moeilijk.
Je moet maar net even weten welke functie je moet gebruiken.

En om daar achter te komen is Helpmij.nl een uitstekend hulpmiddel.
Weer wat geleerd, en nu zien te onthouden. ;)


Vriendelijk bedankt voor alle info. :thumb:
 
Graag gedaan :)
 
mmmm.....

Ik gebruik meerdere e-mail adressen.
laten we zeggen mijn standaard adres is standaard@mail.nl
Het adres waar de facturen op binnenkomen is admin@mail.nl

office 365
map met IMAP items

Code: 
Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.[COLOR="#FF0000"]GetDefaultFolder(olFolderInbox)[/COLOR].Items
End Sub

Naar alle waarschijnlijkheid zal hier iets aangepast moeten worden.

Als ik een mail doorstuur vanuit admin@mail.nl naar standaard@mail.nl, merk ik dat de code iets doet.... een foutmelding komt er:shocked:
Knipsel.PNG

Dit is trouwens eenmalig, wanneer ik nog een mail doorstuur dan gebeurt er niets.
Start ik outlook opnieuw op, dan weer eenmalig de foutmelding.
Kan dit komen door de foutmelding?
 
Laatst bewerkt:
goedemorgen.

Ik had het probleem even laten rusten, nu toch maar weer eens opgepakt.
Ben eerlijk gezegd nog niet verder gekomen, iemand een idee wat er fout is/gaat?
Code: 
Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
    On Error GoTo ErrorHandler
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then
        If InStr(LCase(item.Subject), "factuur", vbTextCompare) > 0 And _
            InStr(LCase(item.Subject), "fuel", vbTextCompare) > 0 And _
            InStr(LCase(item.Subject), "company", vbTextCompare) > 0 Then
            SaveSelectionAttachments
        End If
    End If

ProgramExit:
      Exit Sub

ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

Public Sub SaveSelectionAttachments()
    Dim currentExplorer As Explorer
    Dim PDFroot As String
    Dim Fldr As String
    Dim obj As Object
    Dim i As Integer
    Dim z As Integer

    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection
    PDFroot = "D:\onedrive\1 GAM Transport\Fakturen\Crediteuren\The Fuel Company\"
    
    If Dir(PDFroot, vbDirectory) = "" Then
        MsgBox "De PDF root folder bestaat niet of niet niet toegankelijk" & vbCrLf & PDFroot, vbCritical
        Exit Sub
    End If
    
    For Each obj In Selection
       With obj
           If .Attachments.Count > 0 Then
             For i = 1 To .Attachments.Count
                 If LCase(Right(.Attachments(i).FileName, 3)) = "pdf" Then
                    Fldr = PDFroot '& .SenderEmailAddress
                    If Dir(Fldr, vbDirectory) = "" Then
                        On Error Resume Next
                        MkDir Fldr
                        If Err.Number = 76 Then
                            Fldr = PDFroot & "\Diversen"
                            If Dir(Fldr, vbDirectory) = "" Then
                                MkDir Fldr
                            End If
                        End If
                        On Error GoTo 0
                    End If
                    z = z + 1
                    .Attachments(i).SaveAsFile Fldr & "\" & _
                    Format(Now, "yyyymmddhhmmss_") & _
                    Format(z, "0##_") & _
                    Format(i, "0##_") & _
                    .Attachments(i).FileName
                 End If
             Next i
             MsgBox "PDF opgeslagen", vbInformation
           End If
       End With
    Next

    Set currentExplorer = Nothing
    Set obj = Nothing
    Set Selection = Nothing
End Sub

André
 
Laatst bewerkt:
Loop de code door in debug mode om te zien welke regel de melding veroorzaakt.
Of haal die On Error regel eruit om de code zelf te laten stoppen waar het mis gaat.
 
Laatst bewerkt:
hier loopt ie vast:
Code: 
Private Sub Items_ItemAdd(ByVal item As Object)
'    On Error GoTo ErrorHandler
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then[COLOR="#FF0000"]
        If InStr(LCase(item.Subject), "factuur", vbTextCompare) > 0 And _
            InStr(LCase(item.Subject), "fuel", vbTextCompare) > 0 And _
            InStr(LCase(item.Subject), "company", vbTextCompare) > 0 Then
            SaveSelectionAttachments[/COLOR]
        End If
    End If

ProgramExit:
      Exit Sub

ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

maak ik er het volgende van:

Code: 
Private Sub Items_ItemAdd(ByVal item As Object)
'    On Error GoTo ErrorHandler
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then
        If LCase(item.Subject) = "fw: factuur 173096 the fuel company (10886)" Then
            SaveSelectionAttachments
        End If
    End If

ProgramExit:
      Exit Sub

ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub

dan gebeurt er gewoon niets, ondanks dat ik het onderwerp exact heb ingevuld zoals het in de mail staat wanneer ik deze doorstuur.
De opslag locatie in de code van "SaveSelectionAttachments" klopt.
 
Vreemd.
Probeer eens of dit helpt:
Code: 
Private Sub Items_ItemAdd(ByVal item As Object)
    [COLOR="#FF0000"]On Error GoTo ErrorHandler[/COLOR]
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then
        If InStr(LCase(item.Subject), "factuur", vbTextCompare) > 0 And _
            InStr(LCase(item.Subject), "fuel", vbTextCompare) > 0 And _
            InStr(LCase(item.Subject), "company", vbTextCompare) > 0 Then
            SaveSelectionAttachments
        End If
    End If

ProgramExit:
      Exit Sub

ErrorHandler:
[COLOR="#FF0000"]    If Err.Number = 13 Then
        Resume Next
    Else
        MsgBox Err.Number & " - " & Err.Description
        Resume ProgramExit
    End If[/COLOR]
End Sub
 
Hebbes..... nu slaat ie wel keurig op.
Het werkt dus nu wel, echter waarom die "error 13: Type mismatch" erin komt is me een raadsel.

ik kan in ieder geval weer verder met het aanpassen van de code naar mijn wensen.

wederom bedankt Edmoor
 
Ik denk dat de eerste keer na het starten het betreffende object nog niet is geïnitialiseerd, vandaar die error 13.
 
mmmmm....


Heb er nog niet bij stil gestaan, maar verklaart dat het dat bij de eerste binnenkomende mail de bijlage nog niet opslaat.
bij verdere mails wordt de bijlage wel opgeslagen.

zal outlook opnieuw starten en het nog eens proberen
 
Laatst bewerkt:
Heel vreemd.

na opnieuw starten van outlook wordt de bijlage niet meer opgeslagen.
Het lijkt wel zo te zijn dat de bijlage pas opgeslagen wordt zodra ik een nog niet eerder doorgestuurde mail doorstuur.
Daarna pakt ie alles weer op zoals het hoort.

Heb outlook meerdere keren opnieuw gestart. En iedere keer worden de bijlages van de mails die ik al eerder doorstuurde niet opgeslagen.
Voor het opnieuw starten van Outlook heb ik eerst de ontvangen doorgestuurde mails verwijderd.
 
Laatst bewerkt:
Er is dan kennelijk geen Selection.
Zorg ervoor dat SaveSelectionAttachments() gebruik maakt van het juiste object.
Deze kan je meegeven vanuit Items_ItemAdd(ByVal item As Object).
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan