GDIplusCODE


'参考http://www.excel.studio-kazu.jp/kw/20060917194617.html
Sub trimingPhoto()
  Dim myPic As Shape, myShape As Shape, myRectangle As Shape
  Dim dbl_mypicL As Double, dbl_mypicT As Double
  Dim dbl_mypicW As Double, dbl_mypicH As Double
  Dim dbl_myShapeL As Double, dbl_myShapeT As Double
  Dim dbl_myShapeW As Double, dbl_myShapeH As Double
  Dim dbl_CropLeft As Double, dbl_CropTop As Double
  Dim dbl_CropRight As Double, dbl_CropBottom As Double
  Dim objType As Long
  Dim picArea As Range
  Dim errFlag As Boolean
    
  On Error Resume Next
  '画像以外を選択している場合は抜ける
  objType = Selection.ShapeRange.Type
  If (Err.Number <> 0) Or (objType <> msoPicture) Then
      MsgBox ("トリミングする写真を選択してください。")
      Exit Sub
  End If
  On Error GoTo 0
  Set myPic = ActiveSheet.Shapes(Selection.ShapeRange.Name)
  Set picArea = Range(myPic.TopLeftCell, myPic.BottomRightCell)
  '画像内部に設定されている四角形の取得
  Set myShape = getInsideRectangle(picArea)
  If myShape Is Nothing Then
    MsgBox "トリミング範囲を示す四角形が設定されていません"
    Exit Sub
  End If
  dbl_mypicL = myPic.Left         '写真の左位置
  dbl_mypicT = myPic.Top          '写真の上位置
  dbl_mypicW = myPic.Width        '写真の幅
  dbl_mypicH = myPic.Height       '写真の高さ
  'トリミング範囲チェック
  If myShape.Left < myPic.Left Then errFlag = True
  If myShape.Top < myPic.Top Then errFlag = True
  If myShape.Top + myShape.Height > myPic.Top + myPic.Height Then errFlag = True
  If myShape.Left + myShape.Width > myPic.Left + myPic.Width Then errFlag = True
  If errFlag Then
    MsgBox "トリミング範囲の設定が不適です"
    Exit Sub
  End If
  dbl_myShapeL = myShape.Left     '四角形の左位置
  dbl_myShapeT = myShape.Top      '四角形の上位置
  dbl_myShapeW = myShape.Width    '四角形の幅
  dbl_myShapeH = myShape.Height   '四角形の高さ
  dbl_CropLeft = dbl_myShapeL - dbl_mypicL         '左の調整値
  dbl_CropTop = dbl_myShapeT - dbl_mypicT          '上の調整値
  dbl_CropRight = (dbl_mypicW - dbl_myShapeW) - dbl_CropLeft
  dbl_CropBottom = (dbl_mypicH - dbl_myShapeH) - dbl_CropTop
  On Error Resume Next
  With myPic.PictureFormat
      .CropLeft = dbl_CropLeft       '左の調整
      .CropTop = dbl_CropTop         '上の調整
      .CropRight = dbl_CropRight     '右の調整
      .CropBottom = dbl_CropBottom   '下の調整
  End With
  If Err.Number <> 0 Then _
      MsgBox CStr(Err.Number) & ":" & Err.Description
  On Error GoTo 0
  Set myPic = Nothing
  Set myShape = Nothing
End Sub

Private Function getInsideRectangle(targetRange As Range) As Shape
  Dim shp As Shape
  Dim rectRange As Range
  
  For Each shp In ActiveSheet.Shapes
    If shp.Type = msoAutoShape Then
      If shp.AutoShapeType = msoShapeRectangle Then
        Set rectRange = Range(shp.TopLeftCell, shp.BottomRightCell)
        If Not Intersect(rectRange, targetRange) Is Nothing Then
          Set getInsideRectangle = shp
        End If
      End If
    End If
  Next shp
End Function

☆おまけ
'下記コードでコピー＆ペーストすると、リセットしても元に戻らない画像になる
Sub pasteTrimedPic()
    'xlScreenだと、粗くなってしまう（ファイルサイズは小さくなるかも）
    Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    Range("D39").Select
    ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)", Link:=False, _
        DisplayAsIcon:=False
End Sub
エクセルでフォトレタッチ
