Outlook VBA data importeer probleem

[Joostvk]

Hi,

Ik ben vrij nieuw met VBA. Ik heb een code die ik gebruik om bepaalde informatie uit email berichten te halen en deze te verwerken in Excel. Dit werkt allemaal prima, echter is er een veld in de email, "Comment:" waar geen vaste waarde wordt ingevoerd en dus soms enters voorkomen. Het kopieren van de data stopt na een enter en mis ik de resterende informatie van dat veld. Iemand een idee hoe de code aan te passen zodat het de volledige tekst kopieert naar excel?

Alvast bedankt!

De code die ik gebruik is als volgt:

Sub CopyToExcel()
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
Dim objItem As Object
Dim SenderEmailAddress As String
Dim SenderName As String
Dim Subject As String

Const strPath As String = "V:\DoelBestand.xls"

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("Sheet1")

'Process each selected record
  rCount = xlSheet.UsedRange.Rows.Count
   For Each olItem In Application.ActiveExplorer.Selection
    
    SenderName = olItem.SenderName
    xlSheet.Range("B" & rCount + 1) = SenderName
    
    SenderEmailAddress = olItem.SenderEmailAddress
     xlSheet.Range("A" & rCount + 1) = SenderEmailAddress
     
     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), "country:") > 0 Then
             vItem = Split(vText(i), Chr(58))
             xlSheet.Range("C" & rCount) = Trim(vItem(1))
         End If
         
         If InStr(1, vText(i), "why:") > 0 Then
             vItem = Split(vText(i), Chr(58))
             xlSheet.Range("D" & rCount) = Trim(vItem(1))
         End If
         
         If InStr(1, vText(i), "Interest:") > 0 Then
             vItem = Split(vText(i), Chr(58))
             xlSheet.Range("D" & rCount) = Trim(vItem(1))
         End If
         
         If InStr(1, vText(i), "comment:") > 0 Then
             vItem = Split(vText(i), Chr(58))
             xlSheet.Range("E" & rCount) = Trim(vItem(1))
         End If
         
          If InStr(1, vText(i), "telephone:") > 0 Then
             vItem = Split(vText(i), Chr(58))
             xlSheet.Range("F" & rCount) = Trim(vItem(1))
         End If
         
          If InStr(1, vText(i), "practice:") > 0 Then
             vItem = Split(vText(i), Chr(58))
             xlSheet.Range("G" & rCount) = Trim(vItem(1))
         End If
         
          If InStr(1, vText(i), "role:") > 0 Then
             vItem = Split(vText(i), Chr(58))
             xlSheet.Range("H" & rCount) = Trim(vItem(1))
         End If
         
          If InStr(1, vText(i), "provider:") > 0 Then
             vItem = Split(vText(i), Chr(58))
             xlSheet.Range("I" & 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

 

[snb]

En nu nog even deze code tussen code tags zetten.

Kijk voor wat eenvouidger code eens hier: http://www.snb-vba.eu/VBA_Outlook_external.html#L153