EXCEL VBAで画像をトリミング

質問

Excelのワークシート上に画像(pic1)と四角の図形(waku)があります。

pic1にwakuを重ね、トリミングする場所を視覚的に確認したあと、VBAを実行し、wakuと同じ位置・サイズでpic1をトリミングするということを考えています。

とりあえず、実験的に左側をトリミングするマクロを作ってみましたがうまくいきません。

やってみた手順としては・・・
1.wakuの左端位置を取得
2.pic1の左端位置を取得
3.その差分を取得
4.差分と同サイズ、pic1の左側をトリミングする
・・・です。

Sub 左端をトリミング()

'枠の位置を取得
Dim wLeft As Single
wLeft = ActiveSheet.Shapes("waku").Left

'写真の位置を取得
Dim pLeft As Single
pLeft = ActiveSheet.Shapes("pct1").Left

'左側の差分を取得
Dim lTrim As Single

lTrim = wLeft - pLeft

ActiveSheet.Shapes("pct1").Select
Selection.ShapeRange.PictureFormat.CropLeft = lTrim

End Sub

結果としては想定しているものの２倍分くらい、トリミングされてしまいます。

最後の一文が、よくわからないまま、ネットから拾ってきた感じで使用しており、そこに問題があるのかと思うのですが・・・

どのようにするのが正しいのか、教えていただければ幸いです。

最終的には同様に上端を、右端・下端についてはそれぞれの図形のサイズの差からトリミングすべきポイントを抽出して希望のサイズにトリミングするつもりでいます。

ちなみに趣旨は・・・
・PCの知識の少ない人でも出来るようにしたい。
・wakuをリサイズさせないことで、縦横比・画像サイズを固定したい。
・・・というものです。

「VBAなんか使わなくても、こうすれば簡単じゃん！」みたいな方法があればあわせて教えていただ得れば幸いです。

回答No.4

end-u

とりあえず倍率が問題なら
Sub test()
　　Dim p As Picture
　　Dim s As Shape
　　Dim w As Single
　　Dim h As Single
　　Dim x As Double
　　Dim y As Double

　　Set p = ActiveSheet.Pictures("pct1")
　　Set s = ActiveSheet.Shapes("waku")

　　'wakuサイズ固定したいなら姑息ですが結果オーライな？
　　's.Width = 400
　　's.Height = 300

　　'以下pの倍率取得
　　w = p.Width
　　h = p.Height
　　p.ShapeRange.ScaleWidth 1, msoTrue
　　p.ShapeRange.ScaleHeight 1, msoTrue
　　x = p.Width / w
　　y = p.Height / h
　　'倍率取得したら戻す
　　p.Width = w
　　p.Height = h
　　'トリム処理。マイナス値は考慮してない。
　　With p.ShapeRange.PictureFormat
　　　　.CropLeft = (s.Left - p.Left) * x
　　　　.CropTop = (s.Top - p.Top) * y
　　　　.CropRight = (p.Width - s.Width) * x
　　　　.CropBottom = (p.Height - s.Height) * y
　　End With
　　s.Left = 0
　　s.Top = 0
End Sub
こんな感じで。

以下参考。
四角Shapeにマクロtryを登録し、画像を選択してShapeをクリックすると
マウスカーソルに合わせてShapeが移動します。
トリミング位置に合わせてもう一度Shapeをクリック。

'標準モジュール
Option Explicit
Private Declare Function GetCursorPos Lib "user32" ( _
　　　　　　　　　　　　　　　　　　　ByRef lpPoint As POINTAPI) As Long
Private Declare Sub Sleep Lib "kernel32" ( _
　　　　　　　　　　　　　ByVal dwMilliseconds As Long)
Private Type POINTAPI
　　x As Long
　　y As Long
End Type
Private MoP As POINTAPI
Private flg As Boolean
'-------------------------------------------------
'Shapeは透過、最前面配置にしておく。
'このtryをShapeに登録する。
'Pictureを選択してShapeクリックで実行。
'~~~~~~~~~~~~~~~~~
Sub try()
　　Const DPI As Long = 96 'Dot per inch 取り敢えず固定
　　Const PPI As Long = 72 'Point per inch
　　Dim pc　　As Picture
　　Dim sp　　As Shape
　　Dim w　　 As Single
　　Dim h　　 As Single
　　Dim x　　 As Double
　　Dim y　　 As Double

　　If flg Or (TypeName(Selection) <> "Picture") Then
　　　　flg = False
　　　　Exit Sub
　　End If

　　On Error GoTo ErrHandler

　　flg = True
　　Set pc = Selection
　　With pc.ShapeRange
　　　　.Rotation = 0
　　　　With .PictureFormat
　　　　　　.CropLeft = 0
　　　　　　.CropTop = 0
　　　　　　.CropRight = 0
　　　　　　.CropBottom = 0
　　　　End With
　　End With

　　With Application
　　　　.ScreenUpdating = False
　　　　'WindowZoom100、分割なし限定。
　　　　With .ActiveWindow
　　　　　　.Zoom = 100
　　　　　　.SplitColumn = 0
　　　　　　.SplitRow = 0
　　　　End With
　　　　.ScreenUpdating = True
　　　　.StatusBar = ""
　　　　.Cursor = xlNorthwestArrow
　　　　Set sp = ActiveSheet.Shapes(.Caller)
　　End With

　　Do
　　　　DoEvents
　　　　Call Sleep(1)
　　　　If Not flg Then Exit Do
　　　　Call GetCursorPos(MoP)
　　　　With ActiveWindow
　　　　　　sp.Left = (MoP.x - .PointsToScreenPixelsX(0)) * PPI / DPI - (sp.Width / 2)
　　　　　　sp.Top = (MoP.y - .PointsToScreenPixelsY(0)) * PPI / DPI - (sp.Height / 2)
　　　　End With
　　Loop

　　Application.ScreenUpdating = False
　　With ActiveSheet
　　　　If Not Intersect(.Range(pc.TopLeftCell, pc.BottomRightCell), _
　　　　　　　　　　　　 .Range(sp.TopLeftCell, sp.BottomRightCell)) Is Nothing Then
　　　　　　w = pc.Width
　　　　　　h = pc.Height
　　　　　　pc.ShapeRange.ScaleWidth 1, msoTrue
　　　　　　pc.ShapeRange.ScaleHeight 1, msoTrue
　　　　　　x = pc.Width / w
　　　　　　y = pc.Height / h
　　　　　　pc.Width = w
　　　　　　pc.Height = h
　　　　　　With pc.ShapeRange.PictureFormat
　　　　　　　　.CropLeft = Application.Max(0, (sp.Left - pc.Left) * x)
　　　　　　　　.CropTop = Application.Max(0, (sp.Top - pc.Top) * y)
　　　　　　　　.CropRight = Application.Max(0, (pc.Width - sp.Width) * x)
　　　　　　　　.CropBottom = Application.Max(0, (pc.Height - sp.Height) * y)
　　　　　　End With
　　　　End If
　　End With

　　sp.Left = 0
　　sp.Top = 0

ErrHandler:
　　With Application
　　　　.Cursor = xlDefault
　　　　.StatusBar = False
　　　　.ScreenUpdating = True
　　End With
　　Set pc = Nothing
　　Set sp = Nothing
End Sub

うまくいかない時は捨ててください。