Function zoom(ByVal shape As ShapeRange, ByVal img As image, ByVal rng As Range) Dim orgWidth As Double Dim orgHeight As Double Dim retHeight As Double Dim retWidth As Double Dim toWidth, toHeight As Double orgWidth = img.Picture.Width orgHeight = img.Picture.Height toWidth = rng.MergeArea.Width - 4 toHeight = rng.MergeArea.Height - 4 If toWidth > toHeight Then If orgHeight > orgWidth Then retHeight = toHeight retWidth = orgWidth / orgHeight * toHeight End If If orgHeight < orgWidth Then If orgHeight / orgWidth * toWidth > toHeight Then retHeight = toHeight retWidth = orgWidth / orgHeight * toHeight Else retWidth = toWidth retHeight = orgHeight / orgWidth * toWidth End If End If If orgHeight = orgWidth Then retHeight = toHeight retWidth = orgWidth / orgHeight * toHeight End If End If If toWidth < toHeight Then If orgHeight > orgWidth Then If orgWidth / orgHeight * toHeight > toWidth Then retWidth = toWidth retHeight = orgHeight / orgWidth * toWidth Else retHeight = toHeight retWidth = orgWidth / orgHeight * toHeight End If End If If orgHeight < orgWidth Then retWidth = toWidth retHeight = orgHeight / orgWidth * toWidth End If If orgHeight = orgWidth Then retWidth = toWidth retHeight = orgHeight / orgWidth * toWidth End If End If If toWidth = toHeight Then If orgHeight > orgWidth Then retHeight = toHeight retWidth = orgWidth / orgHeight * toHeight End If If orgHeight < orgWidth Then retWidth = toWidth retHeight = orgHeight / orgWidth * toWidth End If If orgHeight = orgWidth Then retHeight = toHeight retWidth = toWidth End If End If shape.LockAspectRatio = msoFalse shape.Width = retWidth shape.Height = retHeight shape.Rotation = 0# shape.Top = rng.MergeArea.Top + rng.MergeArea.Height / 2 - retHeight / 2 shape.Left = rng.MergeArea.Left + rng.MergeArea.Width / 2 - retWidth / 2 End Function