works in 2007 but not in 2010

[rpick60]

Can anyine tell me why this code qorksa in 2007 but not in 2010?
In 2007 the code pastes the file to the activeworkbook path but in
2010 it does not and it does not error out
The shape is a email that i opened word and pasted it from the
clipboard then copied it into excel

Sub cpemail()

Application.ScreenUpdating = False
'Application.EnableEvents = False
'Unhide
Sheets(1).Unprotect
Columns("L:V").Select
Range("L9").Activate
Selection.EntireColumn.Hidden = False

'Paste email text
Range("B250").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 10).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(0, 10).Range("A1").Select

'Open Word & Paste email
Application.ScreenUpdating = False
Dim xlApp As Object
Set xlApp = CreateObject("word.application")
xlApp.Visible = True
xlApp.Documents.Add Template:="Normal", NewTemplate:=False,
DocumentType:=0
xlApp.Selection.Paste
xlApp.Selection.wholeStory

'Copy Email from Paste in excel
xlApp.Selection.Copy
ActiveSheet.Paste

'Set date, paths and folder names
ActiveCell.Offset(0, -5).Range("A1").Select
ActiveCell.FormulaR1C1 = "=NOW()"
ActiveCell.Select
Selection.Copy
ActiveCell.Offset(0, -15).Range("A1:A2").Select
ActiveSheet.Paste
ActiveCell.Offset(0, 10).Range("A1").Select
ActiveCell.Offset(1, 5).Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[1],""_"",RC[-4])"
ActiveWindow.ScrollColumn = 4
ActiveCell.Select
ActiveCell.Offset(-1, 0).Range("A1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.Copy
ActiveCell.Offset(-1, 2).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ActiveCell.Select
ActiveCell.Replace What:=":", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False,
_
ReplaceFormat:=False
ActiveCell.Offset(1, -2).Range("A1").Select

'Store Folders
Dim srfld As String
Dim emfld As String
srfld = ActiveCell.Offset(-1, 1).Range("A1")
emfld = ActiveCell.Offset(0, 2).Range("A1")

'Move Object(Email) to cell
Dim i As Integer
i = ActiveSheet.Shapes.Count
ActiveSheet.Shapes(i).Select
Selection.ShapeRange.IncrementLeft -1050.65

'Create Folders Sent Received
On Error Resume Next
MkDir srfld
On Error GoTo 0

On Error Resume Next
MkDir emfld
On Error GoTo 0

'Copy Last Object to folder
Dim k As Integer
k = ActiveSheet.Shapes.Count
ActiveSheet.Shapes(i).Copy


'THIS IS THE CODE THAT DOES NOTHING

CreateObject("Shell.Application") _
.Namespace(ActiveWorkbook.Path).Self.InvokeVerb "Paste"



'Close Word
xlApp.Documents.Close SaveChanges:=False
xlApp.Quit
ActiveSheet.Protect DrawingObjects:=False, Contents:=True,
Scenarios:= _
True
Sheets(1).Unprotect

'Hide Columns
Columns("L:V").Select
Range("L9").Activate
Selection.EntireColumn.Hidden = True

ActiveWindow.ScrollColumn = 1

Range("B10").Select
'Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub


Dim k As Integer
k = ActiveSheet.Shapes.Count
ActiveSheet.Shapes(i).Copy
CreateObject("Shell.Application") _
.Namespace(ActiveWorkbook.Path).Self.InvokeVerb "Paste"