画像挿入時のトリミングについて

投稿者 : mio     投稿日時 : 2025/03/15(Sat) 13:11:23     OS : Windows 10     EXCEL : Excel 2019

---

お願いします。

下記の様にWorksheets("レポート")に複数画像を挿入します。

挿入した画像をトリミングしたいのですが

画像によって
A3の画像は下部をトリミング
E3の画像は上半分をトリミング
H3の画像は上下と右側をトリミング
というように画像ごとに異なります。

良い方法のアドバイスを致します。




Dim Path As String
Dim Pname,Pname1,Pname2,Pname3,Pname4 As String


Path = "C:\Users\aaa\デスクトップ\bbb\"


Pname = Worksheets("data").Cells(1, 1).Value
Pname1 = Worksheets("data").Cells(2, 1).Value
Pname2 = Worksheets("data").Cells(3, 1).Value
Pname4 = Worksheets("data").Cells(4, 1).Value

With Worksheets("レポート").Pictures.Insert(Path & Pname)
.Top = Range("A3").Top
.Left = Range("A3").Left
End With

With Worksheets("レポート").Pictures.Insert(Path & Pname1)
.Top = Range("E3").Top
.Left = Range("E3").Left
End With

With Worksheets("レポート").Pictures.Insert(Path & Pname2)
.Top = Range("H3").Top
.Left = Range("H3").Left
End With

投稿者 : POM     投稿日時 : 2025/03/15(Sat) 13:59:30

---

そもそもなぜVBAでトリミングする必要があるのでしょうか？
事前に画像編集ソフトやpythonなどでトリミングしてシートに挿入するのはできないのでしょうか？

複数の画像がどれほどの数か判りませんが
不必要な箇所（範囲）は、VBAを利用する場合もご自身がコードで指定する必要があります。

（例えば、不必要な箇所（範囲）が人間の目では同じ単一色でも
　　実際は微妙な違いが有り自動では処理できません。）


トリミング範囲が同じグループをフォルダー分けして
Pythonでそれにマッチしたコードを作成すれば少しは処理時間の短縮になると思います。

投稿者 : ピロリ     投稿日時 : 2025/03/15(Sat) 20:09:53

---

参考になるか分かりませんが･･･

Sub Sample()
    Dim Path As String
    Dim Pname As String
    Dim Wsh As Worksheet
    Dim Shp As Shape
    
    Path = "C:\Users\aaa\デスクトップ\bbb\"
    'Path = ThisWorkbook.Path & "\"                          '★ for test
    Pname = Worksheets("data").Range("A1").Value
    
    Set Wsh = Worksheets("レポート")
    Wsh.Pictures.Insert (Path & Pname)
    Set Shp = Wsh.Shapes(Wsh.Shapes.Count)      '挿入した最後の画像が処理対象
    With Shp
        '念のため 元のサイズに戻して 縦横比を固定
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue
        .LockAspectRatio = msoTrue
        '画像のトリミング
        .PictureFormat.CropTop = .Height * 0.25             '上部の25%を削除
        .PictureFormat.CropBottom = .Height * 0.25          '下部の25%を削除
        .PictureFormat.CropLeft = .Width * 0.25             '左部の25%を削除
        .PictureFormat.CropRight = .Width * 0.25            '右部の25%を削除
        '画像の位置とサイズの設定
        .Top = Wsh.Range("A3").Top
        .Left = Wsh.Range("A3").Left
        .Width = Wsh.Range("A3").Width          '← 必要ならば、サイズを変更
    End With
End Sub

投稿者 : ピロリ     投稿日時 : 2025/03/16(Sun) 11:34:49

---

サンプルコードを少し直しました。　参考になれば･･･

Sub Sample2()
    Dim Path As String
    Dim Pname As String
    Dim Wsh As Worksheet
    Dim Shp As Shape
    Dim H As Double, W As Double
    
    Path = "C:\Users\aaa\デスクトップ\bbb\"
    'Path = ThisWorkbook.Path & "\"              '★ for test
    Pname = Worksheets("data").Range("A1").Value
    
    Set Wsh = Worksheets("レポート")
    Wsh.Pictures.Insert (Path & Pname)
    Set Shp = Wsh.Shapes(Wsh.Shapes.Count)      '挿入した最後の画像が処理対象
    With Shp
        '念のため 元のサイズに戻して 縦横比を固定
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue
        .LockAspectRatio = msoTrue
        '画像のトリミング
        H = .Height                             '縦サイズを取得
        W = .Width                              '横サイズを取得
        .PictureFormat.CropTop = H * 0.25       '上部の25%を削除
        .PictureFormat.CropBottom = H * 0.25    '下部の25%を削除
        .PictureFormat.CropLeft = W * 0.25      '左部の25%を削除
        .PictureFormat.CropRight = W * 0.25     '右部の25%を削除
        ' ご参考：400ピクセル幅の画像ならば、下はいずれも右部の25%の削除
        ' .PictureFormat.CropRight = 100 * 0.75   '右部の100ピクセルを削除
        ' .PictureFormat.CropRight = 2.64 * 28.34 '右部の2.65cmを削除
        ' .PictureFormat.CropRight = 75           '右部の75ポイントを削除
        '画像の位置とサイズの設定
        .Top = Wsh.Range("A3").Top
        .Left = Wsh.Range("A3").Left
        .Width = Wsh.Range("A3").Width          '← 必要ならば、サイズを変更
    End With
End Sub

投稿者 : mio     投稿日時 : 2025/03/17(Mon) 17:26:17

---

ありがとうございます。
大変勉強になります。

画像が1個だけですと思った通り動作しました。

複数の画像ですと最後の画像にトリミングが集約されてしまいます。

Set Shp = Wsh.Shapes(Wsh.Shapes.Count)

で設定していますので理解できますが

例えば、その都度画像の枚数は分かりますので
3枚ある場合、
1枚目の画像は .PictureFormat.CropTop = H * 0.25
2枚目の画像は .PictureFormat.Cr pBottom = H * 0.5
3枚目の画像は .PictureFormat.CropLeft = W * 0.25

の様な動作設定するには
Wsh.Shapes(Wsh.Shapes.Count)の部分は

どうするのが良いでしょうか？

お時間のあるときに宜しくお願い致します。




■[返信 3] ピロリさん（2025-03-16 11:34:49）の記事
＞ サンプルコードを少し直しました。　参考になれば･･･
＞
＞ Sub Sample2()
＞ Dim Path As String
＞ Dim Pname As String
＞ Dim Wsh As Worksheet
＞ Dim Shp As Shape
＞ Dim H As Double, W As Double
＞
＞ Path = "C:\Users\aaa\デスクトップ\bbb\"
＞ 'Path = ThisWorkbook.Path & "\" '★ for test
＞ Pname = Worksheets("data").Range("A1").Value
＞
＞ Set Wsh = Worksheets("レポート")
＞ Wsh.Pictures.Insert (Path & Pname)
＞ Set Shp = Wsh.Shapes(Wsh.Shapes.Count) '挿入した最後の画像が処理対象
＞ With Shp
＞ '念のため 元のサイズに戻して 縦横比を固定
＞ .ScaleHeight 1, msoTrue
＞ .ScaleWidth 1, msoTrue
＞ .LockAspectRatio = msoTrue
＞ '画像のトリミング
＞ H = .Height '縦サイズを取得
＞ W = .Width '横サイズを取得
＞ .PictureFormat.CropTop = H * 0.25 '上部の25%を削除
＞ .PictureFormat.CropBottom = H * 0.25 '下部の25%を削除
＞ .PictureFormat.CropLeft = W * 0.25 '左部の25%を削除
＞ .PictureFormat.CropRight = W * 0.25 '右部の25%を削除
＞ ' ご参考：400ピクセル幅の画像ならば、下はいずれも右部の25%の削除
＞ ' .PictureFormat.CropRight = 100 * 0.75 '右部の100ピクセルを削除
＞ ' .PictureFormat.CropRight = 2.64 * 28.34 '右部の2.65cmを削除
＞ ' .PictureFormat.CropRight = 75 '右部の75ポイントを削除
＞ '画像の位置とサイズの設定
＞ .Top = Wsh.Range("A3").Top
＞ .Left = Wsh.Range("A3").Left
＞ .Width = Wsh.Range("A3").Width '← 必要ならば、サイズを変更
＞ End With
＞ End Sub
＞

投稿者 : ピロリ     投稿日時 : 2025/03/17(Mon) 18:58:25

---

■[返信 4] mioさん（2025-03-17 17:26:17）の記事
＞ 例えば、その都度画像の枚数は分かりますので
＞ 3枚ある場合、
＞ 1枚目の画像は .PictureFormat.CropTop = H * 0.25
＞ 2枚目の画像は .PictureFormat.CropBottom = H * 0.5
＞ 3枚目の画像は .PictureFormat.CropLeft = W * 0.25
＞ の様な動作設定するには
＞ Wsh.Shapes(Wsh.Shapes.Count)の部分は
＞ どうするのが良いでしょうか？
多分、３画像を全部挿入してから、Set Shp = Wsh.Shapes(Wsh.Shapes.Count) しているのではないですか？
画像を挿入する都度、Set Shp = Wsh.Shapes(Wsh.Shapes.Count) して、Shpを更新すべきでしょう。
下のような感じではいかがですか？

Sub Sample3()
    Dim Path As String
    Dim Pname As String
    Dim Wsh As Worksheet
    Dim Shp As Shape
    Dim H As Double, W As Double
    Dim i As Long
    
    Path = "C:\Users\aaa\デスクトップ\bbb\"
    'Path = ThisWorkbook.Path & "\"              '★ for test
    
    Set Wsh = Worksheets("レポート")
    For i = 1 To 3                                      '画像1～3を１つずつループ処理
        Pname = Worksheets("data").Cells(i, "A").Value  '画像ファイル名を取得して、
        Wsh.Pictures.Insert (Path & Pname)              '画像を挿入する
        Set Shp = Wsh.Shapes(Wsh.Shapes.Count)          'その画像(最後の画像)が処理対象
        With Shp
            '念のため 元のサイズに戻して 縦横比を固定
            .ScaleHeight 1, msoTrue
            .ScaleWidth 1, msoTrue
            .LockAspectRatio = msoTrue
            '画像のトリミング
            H = .Height                                 '縦サイズを取得
            W = .Width                                  '横サイズを取得
            If i = 1 Then                               '１つ目の画像の場合は、
                .PictureFormat.CropTop = H * 0.25       '上部の25%を削除
                .Top = Wsh.Range("A3").Top
                .Left = Wsh.Range("A3").Left
                .Width = Wsh.Range("A3").Width          '← 必要ならば、サイズを変更
            End If
            If i = 2 Then                               '２つ目の画像の場合は、
                .PictureFormat.CropBottom = H * 0.5     '下部の50%を削除
                .Top = Wsh.Range("E3").Top
                .Left = Wsh.Range("E3").Left
                .Width = Wsh.Range("E3").Width          '← 必要ならば、サイズを変更
            End If
            If i = 3 Then                               '３つ目の画像の場合は、
                .PictureFormat.CropLeft = W * 0.25      '左部の25%を削除
                .Top = Wsh.Range("H3").Top
                .Left = Wsh.Range("H3").Left
                .Width = Wsh.Range("H3").Width          '← 必要ならば、サイズを変更
            End If
        End With
    Next i
End Sub

ちなみに、画像を挿入したこのブックを別のパソコンで開くことはないですか？　ブックの配布とか･･･
Pictures.Insertメソッドは、画像ファイルのリンクを張るだけ（画像データ自体は取り込まない）なので、
別のパソコンの「C:¥Users¥aaa¥デスクトップ¥bbb」にも同じ画像ファイルが無いと、リンクエラーになり
画像が表示できません。
もし「ブックの配布」が有り得るのなら、Shapes.AddPictureメソッドを使用するなど、画像データ自体を
取り込んだ方が良いと思います。ファイルサイズは大きくなってしまうでしょうけど･･･
余計なお世話でしたらご免なさい。読み捨てて下さい。

投稿者 : mio     投稿日時 : 2025/03/21(Fri) 17:44:29

---

ありがとうございました。
とても勉強になりました。
感謝です！！



■[返信 5] ピロリさん（2025-03-17 18:58:25）の記事
＞ ■[返信 4] mioさん（2025-03-17 17:26:17）の記事
＞ ＞ 例えば、その都度画像の枚数は分かりますので
＞ ＞ 3枚ある場合、
＞ ＞ 1枚目の画像は .PictureFormat.CropTop = H * 0.25
＞ ＞ 2枚目の画像は .PictureFormat.CropBottom = H * 0.5
＞ ＞ 3枚目の画像は .PictureFormat.CropLeft = W * 0.25
＞ ＞ の様な動作設定するには
＞ ＞ Wsh.Shapes(Wsh.Shapes.Count)の部分は
＞ ＞ どうするのが良いでしょうか？
＞ 多分、３画像を全部挿入してから、Set Shp = Wsh.Shapes(Wsh.Shapes.Count) しているのではないですか？
＞ 画像を挿入する都度、Set Shp = Wsh.Shapes(Wsh.Shapes.Count) して、Shpを更新すべきでしょう。
＞ 下のような感じではいかがですか？
＞
＞ Sub Sample3()
＞ Dim Path As String
＞ Dim Pname As String
＞ Dim Wsh As Worksheet
＞ Dim Shp As Shape
＞ Dim H As Double, W As Double
＞ Dim i As Long
＞
＞ Path = "C:\Users\aaa\デスクトップ\bbb\"
＞ 'Path = ThisWorkbook.Path & "\" '★ for test
＞
＞ Set Wsh = Worksheets("レポート")
＞ For i = 1 To 3 '画像1～3を１つずつループ処理
＞ Pname = Worksheets("data").Cells(i, "A").Value '画像ファイル名を取得して、
＞ Wsh.Pictures.Insert (Path & Pname) '画像を挿入する
＞ Set Shp = Wsh.Shapes(Wsh.Shapes.Count) 'その画像(最後の画像)が処理対象
＞ With Shp
＞ '念のため 元のサイズに戻して 縦横比を固定
＞ .ScaleHeight 1, msoTrue
＞ .ScaleWidth 1, msoTrue
＞ .LockAspectRatio = msoTrue
＞ '画像のトリミング
＞ H = .Height '縦サイズを取得
＞ W = .Width '横サイズを取得
＞ If i = 1 Then '１つ目の画像の場合は、
＞ .PictureFormat.CropTop = H * 0.25 '上部の25%を削除
＞ .Top = Wsh.Range("A3").Top
＞ .Left = Wsh.Range("A3").Left
＞ .Width = Wsh.Range("A3").Width '← 必要ならば、サイズを変更
＞ End If
＞ If i = 2 Then '２つ目の画像の場合は、
＞ .PictureFormat.CropBottom = H * 0.5 '下部の50%を削除
＞ .Top = Wsh.Range("E3").Top
＞ .Left = Wsh.Range("E3").Left
＞ .Width = Wsh.Range("E3").Width '← 必要ならば、サイズを変更
＞ End If
＞ If i = 3 Then '３つ目の画像の場合は、
＞ .PictureFormat.CropLeft = W * 0.25 '左部の25%を削除
＞ .Top = Wsh.Range("H3").Top
＞ .Left = Wsh.Range("H3").Left
＞ .Width = Wsh.Range("H3").Width '← 必要ならば、サイズを変更
＞ End If
＞ End With
＞ Next i
＞ End Sub
＞
＞ ちなみに、画像を挿入したこのブックを別のパソコンで開くことはないですか？　ブックの配布とか･･･
＞ Pictures.Insertメソッドは、画像ファイルのリンクを張るだけ（画像データ自体は取り込まない）なので、
＞ 別のパソコンの「C:¥Users¥aaa¥デスクトップ¥bbb」にも同じ画像ファイルが無いと、リンクエラーになり
＞ 画像が表示できません。
＞ もし「ブックの配布」が有り得るのなら、Shapes.AddPictureメソッドを使用するなど、画像データ自体を
＞ 取り込んだ方が良いと思います。ファイルサイズは大きくなってしまうでしょうけど･･･
＞ 余計なお世話でしたらご免なさい。読み捨てて下さい。