画像ファイルのサイズを変更

画像ファイルのサイズを変更します。

【サンプルプログラム】

Sub Sample()

    ' 画像のフォーマットを変換
    If ConvertImageSize("C:\ExcelVBA\FileTest\img.png", "C:\ExcelVBA\FileTest\img2.png", "JPG") = True Then
        MsgBox "画像ファイルのサイズ変更が成功しました", vbInformation, "画像ファイルのサイズ変更"
    Else
        MsgBox "画像ファイルのサイズ変更が失敗しました", vbExclamation, "画像ファイルのサイズ変更"
    End If
    
End Sub

【関数化】

' ------------------------------------------------------------
' 説明：画像のサイズを変更
' 引数：1:変更元のファイル名
'       2:変更後のファイル名（拡張子は変更元を使用）
'       3:変更後の画像の幅
'       4:変更後の画像の高さ
'       5;アスペクト比を保持 (省略時はTrue)
' 戻値：変換に成功した場合:True
'       変換に失敗した場合:False
' 補足：アスペクト比を保持する場合、アスペクト比を保持した状態で小さいサイズに合わされます。
'       例：800×600 を 2000×300 で指定 → 400×300 になる
' ------------------------------------------------------------
Function ConvertImageSize(imgPath As String, newImgPath As String, imgWidth As Long, imgHeight As Long, Optional AspectRatio As Boolean = True) As Boolean

    Dim WIA As Object
    Dim imgFile As Object
    Dim imgProcess As Object
    Dim imgConverted As Object
    Dim fso As Object
    Dim tempFilename As String
    
    
    On Error GoTo ImageConvertError
    
    
    ' WIAオブジェクトを作成
    Set imgFile = CreateObject("WIA.ImageFile")
    Set imgProcess = CreateObject("WIA.ImageProcess")
    
    ' 画像をロード
    imgFile.LoadFile imgPath
    
    
    ' 画像の最大幅と最大高さをピクセル単位で指定します｡
    ' アスペクト比を保持する場合、指定された幅または高さのいずれかに基づいて画像を縮小。
    ' 比率で計算して、小さいサイズの方に合わせている
    If imgWidth <= 0 Or imgHeight <= 0 Then
        ConvertImageSize = False
        Exit Function
    End If
    
    
    ' 画像サイズ変更のフォーマットを変換
    imgProcess.Filters.Add imgProcess.FilterInfos("Scale").FilterID
    imgProcess.Filters(1).Properties("MaximumWidth").Value = imgWidth
    imgProcess.Filters(1).Properties("MaximumHeight").Value = imgHeight
    imgProcess.Filters(1).Properties("PreserveAspectRatio") = True          ' アスペクト比を保持
    
    ' Objectにフィルタを適用
    Set imgConverted = imgProcess.Apply(imgFile)
    
    ' FileSystem オブジェクトの作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 拡張子を変更したファイル名を取得する
    newImgPath = fso.GetParentFolderName(newImgPath) & "\" & fso.GetBaseName(newImgPath) & "." & fso.GetExtensionName(imgPath)
   
    ' ファイルの有無を確認
    If fso.FileExists(newImgPath) = True Then
        ' ファイルがある場合は、一時的に別名でフォーマット変換する
        
        ' 別名でフォーマット変換する
        tempFilename = fso.GetParentFolderName(newImgPath) & "\" & fso.GetBaseName(fso.GetTempName) & "." & fso.GetExtensionName(imgPath)
        imgConverted.SaveFile tempFilename
        
        ' 元のファイルを削除する
        fso.DeleteFile newImgPath

        ' ファイル名を変更する
        Name tempFilename As newImgPath
    Else
        ' 新しい画像を保存
        imgConverted.SaveFile newImgPath
    End If
    
    ' オブジェクトを解放
    Set imgConverted = Nothing
    Set imgProcess = Nothing
    Set imgFile = Nothing
    Set fso = Nothing
    
    ConvertImageSize = True
    Exit Function
    
ImageConvertError:
    
    ConvertImageSize = False
    
End Function

コメント