Sub ВставитьКартинку(ByRef PicRange As Range, ByVal Pic As String)
    On Error Resume Next
    Dim ph As Picture: Set ph = PicRange.Parent.Pictures.Insert(Pic)
    ph.Top = PicRange.Top + 1: ph.Left = PicRange.Left: k = ph.Width / ph.Height
    ph.Width = PicRange.Width: ph.Height = ph.Width / k
    cell.EntireRow.RowHeight = ph.Height
End Sub

Function InsertWmfPicture(WMFPath)
	' Привяжемся к верхнему левому углу
	rr="A5"
	ObjExc.ActiveSheet.Range(rr).Select
	Set r1 = ObjExc.Range("B6:K18")
	Set  a = ObjExc.ActiveSheet.Pictures.Insert(WMFPath)
       a.ShapeRange.LockAspectRatio = 1
       a.ShapeRange.Height  = r1.Height
       ratio = (a.ShapeRange.Height/a.ShapeRange.Width)
       aspect = (r1.Height/r1.Width)
  If  (ratio<aspect) Then 
			a.ShapeRange.Width  = r1.Width
  End If
  'Выравнять рисунок по центру
   a.ShapeRange.IncrementLeft (ObjExc.Range("A6:K18").Width-a.ShapeRange.Width)/2
   a.ShapeRange.IncrementTop (ObjExc.Range("A5:K19").Height-a.ShapeRange.Height)/2[/color]
End Function