選択画像の幅指定でトリミング

Sub CropPictureKeepLeftCm()
    '----------------------------------------------------------
    ' 選択中の画像（Shape）の左側を指定cmだけ残し、右側をカット
    ' 手作業のトリミングハンドル操作と同等の処理
    '----------------------------------------------------------
    Const sngKeepLeftCm As Single = 3#  ' 残す左側の幅（cm単位）
    
    Dim shpTarget As Shape
    Dim sngKeepPoints As Single
    Dim sngOriginalWidth As Single
    Dim sngOriginalHeight As Single
    Dim sngScaleRatio As Single
    
    ' 選択チェック
    If TypeName(Selection) <> "Picture" And TypeName(Selection) <> "DrawingObjects" Then
        MsgBox "画像を選択してください。", vbExclamation
        Exit Sub
    End If
    
    Set shpTarget = ActiveSheet.Shapes(Selection.Name)
    
    ' 元の表示サイズを保持
    sngOriginalWidth = shpTarget.Width
    sngOriginalHeight = shpTarget.Height
    
    ' cmをポイントに変換
    sngKeepPoints = Application.CentimetersToPoints(sngKeepLeftCm)
    
    ' 残す幅が現在の表示幅以上の場合は処理しない
    If sngKeepPoints >= sngOriginalWidth Then
        MsgBox "残す幅が画像の表示幅以上のため、トリミングしません。", vbExclamation
        Exit Sub
    End If
    
    ' 縮小比率（指定幅 ÷ 元の表示幅）
    sngScaleRatio = sngKeepPoints / sngOriginalWidth
    
    ' 縦横比固定を解除
    shpTarget.LockAspectRatio = msoFalse
    
    ' 表示枠の幅を縮小（高さは変えない、左上基準）
    shpTarget.ScaleWidth sngScaleRatio, msoFalse, msoScaleFromTopLeft
    
    ' トリミング後の画像本体サイズとオフセットを設定
    With shpTarget.PictureFormat.Crop
        .PictureWidth = sngOriginalWidth
        .PictureHeight = sngOriginalHeight
        .PictureOffsetX = (sngOriginalWidth - sngKeepPoints) / 2
        .PictureOffsetY = 0
    End With
    
End Sub