SM78258
11-26-2013, 07:25 AM
Hi guys,I'm a new member here, I've read all the rules but can't seem to find an answer to my specific situation. I use a Macro at work to extract data from Outlook and populate a spreadsheet. We've recently upgraded (from Windows XP to Windows 7) and now the Macro no longer works. The error message that appears is; 429: Active X Component can't create objectThe thing is it doesn't show me where any errors are in the code so I can't spot any issues.I'm wondering if I'm missing something, I've had a look into referencing and that doesn't seem to fix the issue... I've waited a while before posting on here in case I could solve this myself but my boss is expecting an answer by Friday and I'm clueless. Any help or hints would be much appreciated! I know my code is probably awful but I'll attach it anyway.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 SubHandleErr:
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
Thanks for your time guys!
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 SubHandleErr:
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
Thanks for your time guys!