Export specifieke data van een outlook mailtje naar Excel

Status
Niet open voor verdere reacties.
Roeland035 zei:
Hij geeft de volgende fout over de bovenstaande wijziging: Fout 438 tijdens uitvoering: Deze eigenschap of methode wordt niet ondersteund door dit object. Ik weet het helaas niet zo 123 op te lossen.
Klik om te vergroten...

waarschijnlijk dan: xlobj.workbooks.open

van die kleine dingen die je in de haast wel eens vergeet.
 
snb zei:
Kijk, dat zijn tenminste simpele vragen:

Code: 
Sub M_snb()
   With GetObject("C:\Users\r.vanhouten\Documents\Specifications mk1 XXXXXXX rev -.xlsx")
        For Each it In GetNamespace("MAPI").GetDefaultFolder(6).Folders("Offertes").Items
           sn = split(Split(it.Body, "Offerrerequest")(1),vbCrLf)
           .Sheets("Email Data").Cells(1, 2).Resize(UBound(sn) + 1) = .Application.Transpose(sn)
        Next
    End With
 End Sub

Het is ook mogelijk om alle regels die je niet nodig hebt eruit te filteren ( als je de criteria daarvoor specificeert).

NB. ziet er toch wat eenvoudiger uit dan die RegEx expeditie.
Klik om te vergroten...

Haha, deze code is wat sneller en uiteindelijk ook beter geschikt, want het bestand waar de data in moet komen word continue geupdate en als ik deze gegevens op één werkblad laat printen, dan kan ik prima met een matrix verwijzing de data uit dit werkblad opvragen en op de juiste plek zetten in excel zelf.

Hij geeft echter wel een foutmelding over je nieuw gegeven code:

Code: 
sn = Split(Split(it.Body, "Offerrerequest")(1), vbCrLf)
Subscript valt buiten bereik.

Enig idee?

Daarnaast merk ik dat de vorige code het alleen maar goed deed wanneer het excel bestand al open stond. Zodra hij gesloten is en ik de macro run, dan doet geeft hij het laad icoontje, maar daar blijft het dan bij.
 
Laatst bewerkt:
SVP niet citeren/quoten !!

Code: 
sn = Split(Split(it.Body, "Offerrerequest")(1), vbCrLf)

Check dan of het woord "Offerrerequest" goed gespeld is. Ik kan niet in jouw mail kijken.
Als het woord er niet in staat kan er ook niet op gesplitst worden.

Van dat geopende bestand is onzin. Je zorgt er hopelijk wel voor dat een geen beveiliging in zit ?
De macro moet natuurlijk wel in een geopend Excelbestand staan.
 
Laatst bewerkt:
De macro moet worden uitgevoerd vanuit Outlook. Je hebt overigens wel gelijk met dat het woord verkeerd gespeld is. Ik dacht dat er Offerterequest moest komen te staan, maar dat slaat natuurlijk nergens op omdat het in het engels Offerrequest hoort te zijn en zo ook daadwerkelijk in de email geschreven staat.

Tot heden doet hij het alleen maar wanneer het Excel blad geopend staat. Ik neem aan dat dit voortkomt uit het misverstand dat ik het via Outlook uitvoer en jij via Excel?

P.S
Excuus voor de quotes, ik begrijp dat dit het topic onoverzichtelijk maakt.

---UPDATE---
Met een kleine samenvoeging van beide VBA oplossingen heb ik het werkende gekregen waarbij de witregels worden verwijderd. Er worden nog wel screenupdates weergegeven, maar dat is niet zo erg.

Code: 
Sub M_snb()
Dim GrabExcel As Object
Dim xlobj As Object
Dim sourceWB As Workbook
Dim r As Range, rows As Long, i As Long

    Set xlobj = CreateObject("Excel.Application")
        With xlobj
            .Visible = True
            .EnableEvents = False
        End With
        
    strFile = "C:\Users\r.vanhouten\Documents\Specifications mk1 XXXXXXX rev -"
    
    Set sourceWB = xlobj.Workbooks.Open(strFile, False, False)
    sourceWB.Activate

    With sourceWB
        .Application.ScreenUpdating = False
        For Each it In GetNamespace("MAPI").GetDefaultFolder(6).Folders("Offertes").Items
           sn = Split(Split(it.Body, "Offerrequest Qimarox Vertical Conveyors")(1), vbCrLf)
           .Sheets("Email Data").Cells(1, 1).Resize(UBound(sn) + 1) = .Application.Transpose(sn)
        Next
            Set r = ActiveSheet.Range("A1:A200")
                rows = r.rows.Count
                    For i = rows To 1 Step (-1)
                            If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
                    Next
    .Application.ScreenUpdating = True
    End With
End Sub
 
Laatst bewerkt:
'Geopend' is niet hetzelfde als 'zichtbaar'.

Code: 
Sub M_snb()
    With Getobject("C:\Users\r.vanhouten\Documents\Specifications mk1 XXXXXXX rev -.xlsx")
        For Each it In GetNamespace("MAPI").GetDefaultFolder(6).Folders("Offertes").Items
           sn = Split(Split(it.Body, "Offerrequest Qimarox Vertical Conveyors")(1), vbCrLf & vbCrLf)
           .Sheets("Email Data").Cells(1, 2).Resize(UBound(sn) + 1) = .Application.Transpose(sn)
        Next
       .Application.Visible = True
       .Windows(1).Visible = True
    End With
 End Sub

Je kunt beter een voorbeeld (als txt) van de inhoud van zo'n mail plaatsen. Nu is het gokken, omdat ik de opbouw van die mails niet ken.
In deze code ben ik uitgegaan van 2 witregels achter elkaar, maar natuurlijk geen idee.
 
Je hebt volkomen gelijk.
Bekijk bijlage test.txt

Het ziet er uiteraard wel anders uit dan hoe ik het mailtje binnenkrijg, maar ik neem aan dat de spaties en tabs op dezelfde plek zitten als hoe VBA het herkent.

In de onderstaande link staat het emailtje als mailbestand opgeslagen (dropbox), het bijlage programma van deze website ondersteund helaas de extensie niet.
https://www.dropbox.com/s/v06yxyyl9...ia Website www vertical-conveyor com.msg?dl=0
Geheel aan jou om deze dropbox link te willen gebruiken.
 
Laatst bewerkt:
Dat scheelt een slok op een borrel.

Code: 
Sub M_snb()
    With Getobject("C:\Users\r.vanhouten\Documents\Specifications mk1 XXXXXXX rev -.xlsx")
        For Each it In GetNamespace("MAPI").GetDefaultFolder(6).Folders("Offertes").Items
           sn = filter(split(it.Body, vbCrLf),": ")
           .Sheets("Email Data").Cells(1, 2).Resize(UBound(sn) + 1) = .Application.Transpose(sn)
        Next
       .Application.Visible = True
       .Windows(1).Visible = True
    End With
 End Sub
 
Laatst bewerkt:
snb zei:
Dat scheelt een slok op een borrel.
Klik om te vergroten...
Hij geeft een syntaxfout op:
Code: 
sn = filter(it.Body, vbCrLf),": ")
Ik neem aan dat het het volgende moet zijn, maar ook dan geeft hij een fout melding:"
Code: 
sn = filter(it.Body, vbCrLf,": ")

Typen komen niet met elkaar overeen.
 
vorige code aangepast (had je ook zelf kunnen bedenken.)

Gebruik de knop 'reageren op bericht' linksonder het bericht ipv de quote-knop.
 
Laatst bewerkt:
Ik ben niet zo'n held met de functie Filter/Split. Ik dacht dat split misschien niet meer nodig was.

Hij pakt nu alleen de linkerkant van de tabel en zet die mooi strak onder elkaar.
Het lukt mij alleen niet zo gauw om ook de rechterkant van de tabel erbij te pakken.
 
Er staat niks in kolom B, maar ik heb de functie Filter opgezocht en ben er achtergekomen dat het volgende (, False) de rechterkant pakt.
Code: 
sn = Filter(Split(Split(it.Body, "Offerrequest Qimarox Vertical Conveyors")(1), vbCrLf & vbCrLf), ": ",[COLOR="#FF0000"] False[/COLOR])

Het zou wel fijn zijn als ik zowel de Header als de data neer kan zetten.
 
Post #28 gaf hetzelfde effect, alleen dan zijn er nog talloze witregels te vinden. Vandaar dat ik ging experimenteren met de voorgaande code.

Uiteraard zijn die witregels alleen te vinden indien ik er ", false" achter zet, maar als ik dat niet doe, dan pakt hij alleen maar de linkerkolom en verwijderd die wel de witregels.

---UPDATE---

Post #26 doet overigens wel alles wat ik wil :)
Enorm bedankt voor de snelle en hulpvaardige assistentie!
 
Laatst bewerkt:
snb zei:
NB. ziet er toch wat eenvoudiger uit dan die RegEx expeditie.
Klik om te vergroten...
RegEx is net zo cryptisch als jouw vba-code
Je moet er tijd in steken om het te snappen.
En als je het snapt dan is het een krachtig instrument.

In dit probleem wordt de mail automatisch gemaakt en is duidelijk gestructureerd, maar zodra verschillende mensen handmatig dingen gaan invoeren wordt het een ander verhaal.
 
Laatst bewerkt:
Uiteindelijk merk ik toch wat problemen met beide methodes voor mijn probleem.

De code van snb zet alles mooi onder elkaar in kolom A.
Ik heb alleen een regel waarvan de data als volgt is:
100 x 90 x 100 (Length x Width x Height in mm)

Ik probeer vervolgens in mijn excel blad verwijzingen aan te maken om deze data over te nemen, maar ik heb drie headers met elk z'n eigen cel voor de voorgaande data.
Met de formule:
Code: 
=ALS.FOUT(LINKS(INDEX('Email Data'!A:A;VERGELIJKEN("Minimum product size: ";'Email Data'!A:A;0)+1;1);VIND.ALLES(" ";INDEX('Email Data'!A:A;VERGELIJKEN("Minimum product size: ";'Email Data'!A:A;0)+1;1))-0);"")
weet ik het getal 100 te pakken, maar als ik de 90 of de tweede 100 apart wil pakken, dan is het een ander verhaal. Ik heb geen idee hoe ik dat zo snel doe in Excel.
Hierbij is RegEx weer handig, omdat je zelf aan kan geven welk stukje van een string je over wilt nemen. Maar een bedrijfsnaam (die ook overgenomen moet worden) kan weer variëren in spaties aantal woorden. Waar RegEx geen rekening mee kan houden zover ik weet. Ik zou eventueel beide macro's kunnen gebruiken en de RegEx laten oriënteren op de niet variabele informatie en de formule van snb op alleen de bedrijfsnaam.
 
in A1
Code: 
200 x 50 x 300
in B1
Code: 
=WAARDE(DEEL(A1;1;VIND.ALLES("|";SUBSTITUEREN(A1;"x";"|";1);1)-1))
in C1
Code: 
=WAARDE(DEEL(A1;VIND.ALLES("|";SUBSTITUEREN(A1;"x";"|";1);1)+1;VIND.ALLES("|";SUBSTITUEREN(A1;"x";"|";2);1)-VIND.ALLES("|";SUBSTITUEREN(A1;"x";"|";1);1)-1))
in D1
Code: 
=WAARDE(DEEL(A1;VIND.ALLES("|";SUBSTITUEREN(A1;"x";"|";2);1)+1;LENGTE(A1)-VIND.ALLES("|";SUBSTITUEREN(A1;"x";"|";2);1)))

of

matrix UDF, selecteer 3 horizontale cellen en bevestig met CTRL+SHIFT+ENTER
Code: 
Public Function LBH(rngCell As Range)
    LBH = Split(UCase(Trim(Replace(rngCell.Value, " ", ""))), "X")
End Function
 
Laatst bewerkt:
Bedankt AlphaMax!
Nu kan ik heel mooi de code van snb combineren met deze formules :)
 
Weet iemand toevallig hoe ik het script over een geselecteerd mailtje kan laten runnen ipv allemaal in eenzelfde map?

Code: 
Sub M_snb()
    With Getobject("C:\Users\r.vanhouten\Documents\Specifications mk1 XXXXXXX rev -.xlsx")
        For Each it In GetNamespace("MAPI").GetDefaultFolder(6).Folders("Offertes").Items
           sn = filter(split(it.Body, vbCrLf),": ")
           .Sheets("Email Data").Cells(1, 2).Resize(UBound(sn) + 1) = .Application.Transpose(sn)
        Next
       .Application.Visible = True
       .Windows(1).Visible = True
    End With
 End Sub
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan