Inserting an object into a cell

[dlm]

Since upgrading to 2007 I have had an issue with a VBA macro that
places a drawing(triangle) into selected cells. The object shows up
but it is not quite in the correct position and as the object is
pasted/inserted across the page it moves further out of the selected
cell. This sheet was orginally written in excel 95.
Please help.
Thank you in advance!

Here is the code.

Private Sub PutSchedPics(NewName)
'Adjust heights added 1/8/00
' Dim MTRows As Integer
Dim ZeroRows As Integer
Dim ShiftlyRows As Integer
' MTRows = 0
ZeroRows = 0
ShiftlyRows = 0
For i = 7 To 39
If ActiveSheet.Cells(i, 5).Value = "" Then
If ZeroRows < ShiftlyRows Then
Rows(i).RowHeight = 0
ZeroRows = ZeroRows + 1
End If
ElseIf ActiveSheet.Cells(i, 5).Value = "S" Then
Sheets(NewName).Rows(i).RowHeight = 30
ShiftlyRows = ShiftlyRows + 1
ElseIf ActiveSheet.Cells(i, 41).Value = 0 Then
Rows(i).RowHeight = 14.5
Else
Rows(i).RowHeight = 14.5
End If
Next


For r = 7 To 39
If Cells(r, 5) = "S" Then
Sheets("Misc").Activate
' Sheets("Misc").DrawingObjects("bmpShiftly").Select
Sheets("Misc").DrawingObjects("DrawShiftly").Select
Else
Sheets("Misc").Activate
' Sheets("Misc").DrawingObjects("bmpScheduled").Select
Sheets("Misc").DrawingObjects("DrawScheduled").Select
End If
Selection.Copy
Sheets(NewName).Activate
For c = 9 To 39
If Cells(r, c) > 0 Then
ActiveSheet.Paste
Selection.Left = ActiveSheet.Columns(c).Left + 1
Selection.Top = ActiveSheet.Rows(r).Top + 1
Selection.Height = ActiveSheet.Rows(r).RowHeight - 2
Selection.Width = ActiveSheet.Columns(c).Width - 2
Selection.Placement = xlMoveAndSize
Selection.PrintObject = True
Selection.Name = Selection.Name + "0" + CStr(r) + "0"
+ CStr(c)
End If
Next c
Next r
End Sub