『トリミング（切り出し）』（joy）
EXCELのVBAでファオルダー内の複数画像(JPEG)を指定サイズで一括トリミング（切り出し）して
同名で保存するようにしたいです。
例えば、1280ｘ720をトリミングする場合
左上角の座標 280，0 ＜----（1280-720)/2＝280
サイズ 720ｘ720 （正方形）＜-------- オリジナルの縦サイズ
アスペクト比は維持しない
コードを考えていますが、トリミングをどうするのかで止まっています。
サンプルコードをお願いできないでしょうか ？
Sub TrimAndSaveImages()
Dim folderPath As String
Dim targetWidth As Long
Dim targetHeight As Long
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim img As Object
Dim newFilePath As String
Dim leftOffset As Long
' フォルダパス
folderPath = "C:\Users\TAC_\test\"
'参照＞ 「Microsoft Scripting Runtime」
'以下は、参照設定を使わない方法
' フォルダ内のファイルを取得
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)
'参照＞「Microsoft Windows Image Acquisition Library 2.0」
' 各ファイルに対してトリミングを実行
For Each file In folder.Files
If LCase(Right(file.Name, 4)) = ".jpg" Or LCase(Right(file.Name, 5)) = ".jpeg" Then
Set img = CreateObject("WIA.ImageFile")
img.LoadFile file.Path
targetWidth = img.Width
targetHeight = img.Height
leftOffset = (img.Width - img.Height) / 2
' トリミング
' 新しいファイルパスを作成
newFilePath = folderPath & "Trimmed_" & file.Name
' トリミングした画像を保存
End If
Next file
MsgBox "トリミングが完了しました。"
End Sub
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
勘で...
' トリミング
With CreateObject("WIA.ImageProcess")
.Filters.Add .FilterInfos("Crop").FilterID
.Filters(1).Properties("Left") = leftOffset
.Filters(1).Properties("Right") = leftOffset
' 新しいファイルパスを作成
newFilePath = folderPath & "Trimmed_" & file.Name
' トリミングした画像を保存
Apply(img).SaveFile newFilePath
End With
（白茶） 2024/04/08(月) 15:16:06
コードで目的の事できました。
applyの前に「.」が無かったので追加しました。
.Apply(img).SaveFile newFilePath
’-----
（joy） 2024/04/08(月) 16:22:52
あらら。失礼しやした。^^; ちなみにGDI+を直に使う場合は「GdipDrawImageRectRectI」ってのでイケそうな感じでした。(色調補正に使ったりするヤツですね〜)
Private Enum GpUnit
UnitWorld = 0
UnitDisplay = 1
UnitPixel = 2
UnitPoint = 3
UnitInch = 4
UnitDocument = 5
UnitMillimeter = 6
End Enum
Private Declare PtrSafe Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal graphics As LongPtr, ByVal image As LongPtr, _
ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, _
ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As GpUnit, _
Optional ByVal imageAttributes As LongPtr = 0, Optional ByVal callback As LongPtr = 0, Optional ByVal callbackData As LongPtr = 0) As Long
（白茶） 2024/04/08(月) 16:50:56
Sub TrimAndSaveImages()
Dim folderPath As String
Dim targetWidth As Long
Dim targetHeight As Long
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim img As Object
Dim newFilePath As String
Dim leftOffset As Long
Dim topOffset As Long
Dim flag As Long
' フォルダパス
folderPath = "C:\Users\TAC_\test\" '
'参照＞ 「Microsoft Scripting Runtime」
'以下は、参照設定を使わない方法
' フォルダ内のファイルを取得
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)
'参照＞「Microsoft Windows Image Acquisition Library 2.0」
' 各ファイルに対してトリミングを実行
For Each file In folder.Files
If LCase(Right(file.Name, 4)) = ".jpg" Or LCase(Right(file.Name, 5)) = ".jpeg" Then
'画像ファイルのパターンで区別
flag = Left(file.Name, 1)
Set img = CreateObject("WIA.ImageFile")
img.LoadFile file.Path
Select Case flag
Case 1
targetWidth = img.height
targetHeight = img.height
leftOffset = (img.Width - img.height) / 2
' トリミング
With CreateObject("WIA.ImageProcess")
.Filters.Add .FilterInfos("Crop").FilterID
.Filters(1).Properties("Left") = leftOffset
.Filters(1).Properties("Right") = leftOffset
' 新しいファイルパスを作成 (ファイル名の最後に(new)を追加）
newFilePath = folderPath & fso.GetBaseName(file.Name) & "(new)." & fso.GetExtensionName(file.Name)
' トリミングした画像を保存
.Apply(img).SaveFile newFilePath
End With
Case 2
targetWidth = (img.height + img.widt) / 2
targetHeight = (img.height + img.widt) / 2
Dim picBox As Object
Set picBox = CreateObject("Scripting.Dictionary")
picBox.Add "Picture", img
picBox.Add "Width", targetWidth
picBox.Add "Height", targetHeight
’保存
SavePicture picBox("Picture"), folderPath & fso.GetBaseName(file.Name) & "(new)." & fso.GetExtensionName(file.Name)
End Select
End If
Next file
MsgBox "トリミングが完了しました。"
End Sub
（joy） 2024/04/09(火) 06:25:54
Case2 のコードを全面的に見直し中なので
質問自体をCANCELとしたいので、これ以上の回答は必要ありません。
（joy） 2024/04/09(火) 12:16:17
>これ以上の回答は必要ありません。 との事ですが、 後からここを訪れる人々の為にサラッとだけ書いておきますと...
SavePictureで画像をファイル保存するには[IPictureDisp]を引数に指定しないと型エラーになります。 Dictionaryに登録しようとも元々[ImageFile]でしかありませんので、SavePictureは使えません。
どうしてもSavePictureを使いたいのなら、何とかして[ImageFile]から[IPictureDisp]を作る必要があります。 (出来ない事は無いとは思いますが、ちょっと複雑で面倒な手順になるでしょね) まあ画像をファイル保存のが目的なら、わざにここでSavePictureを使う必要もありませんし。
ちなみに、SavePictureで保存されたjpgファイルは、 「いや、だったらbmpでいいよ」って結果になる事が多々ありますので、私は好んで使おうとは思いません。
（白茶） 2024/04/09(火) 14:26:27
あ。あと
（白茶） 2024/04/08(月) 16:50:56 の発言は
[[20240330113454]]の続きだと解釈しての発言です。
今読み返してみたら自分でも「なんのこっちゃ?」って思ったので補足。^^;
（白茶） 2024/04/09(火) 14:26:55
おやおや〜? ちょっとぉ〜?
こwwwれwwwはwww 恥かしい事態判明。^^;
>> どうしてもSavePictureを使いたいのなら、何とかして[ImageFile]から[IPictureDisp]を作る必要があります。 >> (出来ない事は無いとは思いますが、ちょっと複雑で面倒な手順になるでしょね)
>> 複雑で面倒な手順 ← >> 複雑で面倒な手順 ← >> 複雑で面倒な手順 ←
いやいやいや、全っっっっ然簡単な話やったで。もうびっくりですわ。orz
Dim wiaIF As New WIA.ImageFile, p As IPictureDisp
wiaIF.LoadFile "C:\xxx\test1.jpg"
Set p = wiaIF.ARGBData.Picture(wiaIF.Width, wiaIF.Height)
SavePicture p, "C:\xxx\test2.jpg"
WIAスゲーっすね。 ImageProcessのFilter達も、GDI+グラフィックス関数の呼び出し簡素化っぽい構成で なんか色々とハードル下げてくれるっぽいです。 地味に優秀w
How to Use Filters | Microsoft Learn
https://learn.microsoft.com/en-us/previous-versions/windows/desktop/wiaaut/-wiaaut-howto-use-filters
てか、何せ情報乏しい...
（白茶） 2024/04/09(火) 22:43:35
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.