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
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
and then it hits this next and it breaks (this is the new one with the classifier)
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
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
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.
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
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
and then it hits this next and it breaks (this is the new one with the classifier)
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
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
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.