VBA で画像のサイズ変更（解像度を下げる）

画像をリサイズするフリーソフトは山ほどあるし、Excelシートに挿入した画像のファイルサイズを小さくするのなら基本機能の「図の圧縮」を使うのも良いのですが、VBAでもリサイズのコードを書くことができます。WMIというライブラリがあると聞き、早速使ってみました。

使い方

参照設定で Microsoft Scripting Runtime と　Microsoft Windows Image Acquisition Library にチェックを入れて下記のコードを標準モジュールに貼り付けて使って下さい。元の画像のフルパスとリサイズ後の画像のフルパス、拡大/縮小率を渡せば実行されます。

リサイズ後の画像の名前と同じ名前の画像が同じフォルダ内にある場合は、古いファイルは上書きされるので注意して下さい。

---

サンプルコード

'参照設定 'Microsoft Scripting Runtime 'Microsoft Windows Image Acquisition Library

Sub resizeImage(srcImgPath As String, destFolderPath As String, resizeRatio As Single) Dim FSO As FileSystemObject: Set FSO = New FileSystemObject Dim srcImgName As String: srcImgName = FSO.GetFileName(srcImgPath) Dim outImgName As String: outImgName = srcImgName Dim outImgPath As String: outImgPath = destFolderPath & "\" & outImgName If FSO.FileExists(outImgPath) Then FSO.DeleteFile (outImgPath) Dim img As wia.ImageFile: Set img = New wia.ImageFile img.LoadFile (srcImgPath) Dim oriWidth As Long, oriHeight As Long Dim newWidth As Long, newHeight As Long

oriWidth = img.Width oriHeight = img.Height newWidth = oriWidth * resizeRatio newHeight = oriHeight * resizeRatio Dim ip As wia.ImageProcess: Set ip = New wia.ImageProcess

ip.Filters.Add (ip.FilterInfos("Scale").FilterID) ip.Filters(1).Properties("MaximumWidth").Value = newWidth ip.Filters(1).Properties("MaximumHeight").Value = newHeight ip.Filters(1).Properties("PreserveAspectRatio").Value = True Set img = ip.Apply(img) img.SaveFile (outImgPath) Set FSO = Nothing Set img = Nothing Set ip = Nothing End Sub