Outlook to VBA

MrSumo85

New Member
Joined
Dec 3, 2020
Messages
1
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi guys

First time poster long time user!

I've had code that has worked for years and now my company has started upgrading everyone to Win10 :cry:

Basically, this code has worked perfectly for years and now it stops at random intervals because some users are on Win10 laptops and some are on Win7 laptops.

The code below pulled everything into a spreadsheet line by line from the body into separate cells one row per email.

Now because of a new classifier email protection it has messed up the code.

Example:
This works
1607035319118.png


and then it hits this next and it breaks (this is the new one with the classifier)
1607035427711.png


You can see that now the classifier adds the classifier subject then some empty lines then the data

This is the code:

Public Sub ImportOutlookItems()
On Error GoTo HandleErr

Dim Olapp As Outlook.Application
Dim Olmapi As Outlook.NameSpace
Dim OlDealfolder As Outlook.MAPIFolder
Dim OlDealCountedfolder As Outlook.MAPIFolder
Dim OlMailbox As Outlook.MAPIFolder
Dim OlMail As Object 'Have to late bind as appointments e.t.c screw it up
Dim OlItems As Outlook.Items
Dim x, count_items As Integer
'Create a connection to outlook
Set Olapp = CreateObject("Outlook.Application")
Set Olmapi = Olapp.GetNamespace("MAPI")
'Set OlMailbox = Olmapi.GetDefaultFolder(olFolderInbox) ' use this for personal default inbox
Sheets("Macro").Select
Set OlMailbox = Olmapi.Folders(ActiveSheet.Range("mailbox").Value)
Set OlDealfolder = OlMailbox.Folders("inbox").Folders(ActiveSheet.Range("inbox").Value)
Set OlDealCountedfolder = OlDealfolder.Folders(ActiveSheet.Range("movedbox").Value)

Set OlItems = OlDealfolder.Items

'move to the next new row in the spreadsheet
Sheets("Data").Select
ActiveSheet.Range("A2").Select
If Not Range("A2").Value = "" Then ' caters for a blank spreadsheet
'move down a cell until a blank row is found
Do
ActiveCell.Offset(1, 0).Activate
Loop Until ActiveCell.Value = Empty
End If

' Count the number of items in the inbox
count_items = OlItems.Count

'Set up a loop to run from last to first (otherwise it skips some)
For x = OlItems.Count To 1 Step -1
ActiveCell.Value = OlItems(x).SenderName
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = OlItems(x).SentOn
getContents (OlItems(x).body)
ActiveCell.Offset(1, 0).Activate
Selection.End(xlToLeft).Select
OlItems(x).Move OlDealCountedfolder
Next x
' ActiveSheet.Unprotect
' Columns("A:C").Select
' Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
' OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' Range("A2").Select
' ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
MsgBox "Update completed. " & count_items & " emails copied.", vbInformation, "Import Email"



ExitHere:
Exit Sub

HandleErr:
Select Case Err
Case Else
MsgBox Err & ": " & Err.Description
End Select
Resume ExitHere


End Sub
Function getContents(body) As Boolean
Dim temp As String
Dim pos As Integer
Dim temp_length As Integer

'If Not InStr(1, body, "StartForm=") Then
' MsgBox "A message in this folder does not have the appropriate start tag.", vbCritical
' getContents = False
' Exit Function
'End If

While InStr(1, body, ":")
temp_length = InStr(1, body, Chr(13)) - InStr(1, body, ":") - 1
pos = InStr(1, body, Chr(13)) + 1
temp = Mid(body, InStr(1, body, ":") + 1, temp_length)
body = Mid(body, pos)
If temp = "Submit" Then Exit Function
If InStr(1, temp, ":") = 0 Then
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = temp
End If
Wend

End Function


It works from a spreadsheet with two tabs
the first is where the data appears
1607035625282.png

The second is a guide to find the mailbox (out of multiple mailboxes within Outlook) and then the folder and the done folder to put it in

1607035708995.png

Any help would be MASSIVELY appreciated as its doing my nut in doing it manually

I'm sure there will be a simple bit of code to ay grab all the data from the body instead of this : separated bit. I can figure the rest out in Excel afterwards.
1607035974026.png
 

Some videos you may like

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

Watch MrExcel Video

Forum statistics

Threads
1,127,650
Messages
5,626,084
Members
416,161
Latest member
David1966Lewis

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top