2012 m. rugsėjo 6 d., ketvirtadienis

Read picture from file to Excel shape from cell text


Sub InsertPic()
Dim fname
Dim DrObj
Dim Pict
Set DrObj = ActiveSheet.DrawingObjects

For Each Pict In DrObj
  If Left(Pict.Name, 7) = "Picture" Then
  Pict.Select
  Pict.Delete
  End If
Next

On Error GoTo ErrNoPhoto:
fname = ActiveCell.Text
ActiveSheet.Pictures.Insert (fname)
Set DrObj = ActiveSheet.DrawingObjects
For Each Pict In DrObj
  If Left(Pict.Name, 7) = "Picture" Then
   Pict.Select
   With Selection
        .ShapeRange.Top = ActiveCell.Top
        .ShapeRange.Left = ActiveCell.Left + ActiveCell.Width
        .ShapeRange.Height = 120#
        .ShapeRange.Rotation = 0#
    End With
  End If
Next

Exit Sub
ErrNoPhoto:
    MsgBox "No pic!"
    Exit Sub
End Sub