Ik ben relatief nieuw met VBA code en probeer een code te maken, waarbij ik graag in Microsoft Outlook...
Het is mij inmiddels gelukt om delen van de tekstvelden als strings naar mijn Excel-bestand te kopiëren (tabblad 2 van het Excel-bestand). Dit deel werkt dus, met per geselecteerde e-mail een nieuwe regel.
Ik krijg het echter niet voor elkaar om ook de datum waarop de e-mail ontvangen is (notatie als: 26-10-18) in het excel bestand op te laten nemen (in cel/kolom F van van elke nieuwe regel).
Het zou de bedoeling zijn om een online aanmeldformulier, wat ik als e-mail ontvangen heb, te laten 'scannen' door de Macro en delen van de inhoud te plaatsen naar het ecxel bestand.
Welke code dien ik op welke locatie in te voegen? Ik heb al iets gevonden met Dim olItem As Outlook.MailItem, maar verder kom ik niet.
Hieronder mijn reeds bestaande code:
- de datum waarop ik een e-mail heb ontvangen
- tekstdelen van die e-mail (die afkomstig zijn vanuit een online formulier)
Het is mij inmiddels gelukt om delen van de tekstvelden als strings naar mijn Excel-bestand te kopiëren (tabblad 2 van het Excel-bestand). Dit deel werkt dus, met per geselecteerde e-mail een nieuwe regel.
Ik krijg het echter niet voor elkaar om ook de datum waarop de e-mail ontvangen is (notatie als: 26-10-18) in het excel bestand op te laten nemen (in cel/kolom F van van elke nieuwe regel).
Het zou de bedoeling zijn om een online aanmeldformulier, wat ik als e-mail ontvangen heb, te laten 'scannen' door de Macro en delen van de inhoud te plaatsen naar het ecxel bestand.
Welke code dien ik op welke locatie in te voegen? Ik heb al iets gevonden met Dim olItem As Outlook.MailItem, maar verder kom ik niet.
Hieronder mijn reeds bestaande code:
Code:
Sub CopyToExNL()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "BESTANDSPAD VAN EXCEL BESTAND HIER" 'the path of the workbook
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Blad2")
'Process each selected record
rCount = xlSheet.UsedRange.Rows.Count
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Voornaam: ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Achternaam: ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Opdrachtgever(s) / bedrijfsnaam: ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Telefoonnummer: ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "E-mail: ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Functie: ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("J" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Parkeerkaart: ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("K" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
