GDIplusCODE


	
Sub test()
    Dim srcPath As String, dstPath As String
    
    srcPath = "c:\sample1.jpg"
    dstPath = "c:\sample2.jpg"
    'もしファイルが存在する場合は削除してから実行しないと、ファイルが見かけ上小さくならない
    If Dir(srcPath) = "" Then
        MsgBox "ファイルがみつかりません"
        Exit Sub
    End If
    If Dir(dstPath) <> "" Then Kill (dstPath)
    Call resizePicture(srcPath, dstPath, scalerate:=20, _
            InterpolationMode:=InterpolationModeHighQualityBicubic, _
            jpegQuality:=10)
End Sub

' 拡大率と補間モードを指定してファイルから画像をロード
Public Function resizePicture( _
              ByVal srcPath As String, _
              ByVal dstPath As String, _
              Optional ByVal scalerate As Long = 100, _
              Optional ByVal InterpolationMode As InterpolationMode _
                           = InterpolationModeHighQualityBicubic, _
              Optional ByVal jpegQuality As Long = 85 _
              )
    Dim IID_IDispatch As GUID
    Dim pd As PICTDESC
    Dim udtInput  As GdiplusStartupInput
    Dim lngToken  As Long, lngStatus As Long
    Dim pGraphics As Long
    Dim pSrcBmp   As Long, pDstBmp As Long
    Dim lngWidth  As Long, lngHeight As Long
    Dim EncodParameters     As EncoderParameters
    
    ' 初期化
    udtInput.GdiplusVersion = 1
    If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
        Exit Function
    End If

    ' 画像の読みこみ
    If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath), pSrcBmp) <> 0 Then
        GdiplusShutdown lngToken
        Exit Function
    End If

    ' 元画像サイズの取得
    GdipGetImageWidth pSrcBmp, lngWidth
    GdipGetImageHeight pSrcBmp, lngHeight
    ' サイズの変更 (エラー処理は必要に応じて追加のこと)
    lngWidth = lngWidth * scalerate \ 100
    lngHeight = lngHeight * scalerate \ 100

    If GdipGetImageGraphicsContext(pSrcBmp, pGraphics) = 0 Then
        ' コピー先Bitmap作成
        lngStatus = GdipCreateBitmapFromGraphics( _
                        lngWidth, lngHeight, pGraphics, pDstBmp)
        GdipDeleteGraphics pGraphics
        If lngStatus = 0 Then
            ' コピー用Graphics作成
            If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
                ' 補間方法の設定
                GdipSetInterpolationMode pGraphics, InterpolationMode
                ' イメージのコピー
                GdipDrawImageRectI pGraphics, pSrcBmp, 0, 0, lngWidth, lngHeight
                GdipDeleteGraphics pGraphics
                ' エンコーダパラメータ設定
                EncodParameters.Count = 1
                With EncodParameters.Parameter(0)
                    .GUID = ConvCLSID(CLSID_Quality)
                    .NumberOfValues = 1
                    ' 4=EncoderParameterValueTypeLong
                    .Type = 4
                    ' 圧縮品質
                    .Value = VarPtr(jpegQuality)
                End With
                ' JPG変換で保存
                Call GdipSaveImageToFile(pDstBmp, StrPtr(dstPath), ConvCLSID(CLSID_JPEG), VarPtr(EncodParameters))
            End If
            GdipDisposeImage pDstBmp
        End If
    End If
    GdipDisposeImage pSrcBmp
    GdiplusShutdown lngToken
End Function

Private Function ConvCLSID(ByVal sGuid As String) As GUID
    CLSIDFromString StrPtr(sGuid), ConvCLSID
End Function
画像ファイルを読込、リサイズし、圧縮率指定でJPEG保存【XL2010 OK】
