Excel VBA 質問スレッド No.149 (未解決)

1000枚の画像を画像毎に指定した座標通りにトリミングしたい。

投稿者 : 初心者太郎     投稿日時 : 2020/12/25(Fri) 14:34:02     OS : Windows 10     EXCEL : Excel 2016
フォルダに1000枚の画像(サイズはx:1254pixel,y:1254pixel)が入ってます。
エクセルには各画像で四角にトリミングしたい座標4点を示しています。(下記)
画像とエクセル情報を読み込んでトリミングするVBAを作りたいです。
初心者で全く分からないです。どうかご教授お願いします。

画像 ,A座標 , B座標 ,C座標 ,D座標
1.jpg,(400,400),(800,400),(400,800),(800,800)
2.jpg,(100,200),(500,200),(100,600),(500,600)
3.jpg,(600,300),(1000,300),(600,700),1000,700)



[返信 1] Re : 1000枚の画像を画像毎に指定した座標通りにトリミングしたい。
投稿者 : EUNO     投稿日時 : 2021/01/04(Mon) 14:45:37
Sub test()

仮にSheet1にトリミングの情報が入っていて、Sheet2に画像を挿入していくとします。
画像データはExcelのマクロブックと同じフォルダに入っているものとします。

sheet1にあるトリミング情報ですが、ちょっと変更して下記のような書式にしてみました。
ここでは、A列に画像のファイル名を連番で入れています。
さらに設定を簡単にするため、1.jpgのトリミングデータは2行目のデータを参照、
2.jpgは3行目のデータを参照・・・(以下略)するようにします。
(つまり画像のファイル名でVlookup関数みたいな表引きにしていません)

   Top Bottom Left Right
1.jpg 200 300 100 250
2.jpg 100 300 100 250
3.jpg 50 300 100 250
4.jpg 200 300 100 250
5.jpg 200 300 100 250
6.jpg 30 300 100 250

Sub test()

Dim i As Long

For i = 1 To 6

Worksheets("Sheet2").Pictures.Insert(ThisWorkbook.Path & "\" & i & ".jpg").Name = "Shape" & i

With Worksheets("Sheet2").Shapes("Shape" & i)
.PictureFormat.CropTop = Worksheets("Sheet1").Cells(i + 1, 2)
.PictureFormat.CropLeft = Worksheets("Sheet1").Cells(i + 1, 3)
.PictureFormat.CropBottom = Worksheets("Sheet1").Cells(i + 1, 4)
.PictureFormat.CropRight = Worksheets("Sheet1").Cells(i + 1, 5)
End With

Next i

End Sub


・エラー処理をしていない
・画像の挿入位置が一か所に集中するため画像が重なってしまう
などなど未完成ですが、参考までに。

[返信 2] Re : 1000枚の画像を画像毎に指定した座標通りにトリミングしたい。
投稿者 : EUNO     投稿日時 : 2021/01/04(Mon) 17:31:50
すみません、ちょっと間違えてます。
CropRightは座標じゃなくて元の画像の右側からどれだけトリミングするか(単位:ポイント)でした。
CropBottomも同様です。取り急ぎ。

当掲示板について
返信入力フォーム
お 名 前  :
内  容   :
ステータス  : この質問を解決済みにする

認証コード  :
        キャプチャ画像


( 処理日時 : 2021-01-27 12:18:13 )

Page
Top