GDIplusCODE

Sub 呼び出し例()
    Dim FileName As String
    
    FileName = "c:\sample.jpg"
    With UserForm1
        Set .Picture = LoadPictureScaled(FileName, scalerate:=200, _
            InterpolationMode:=InterpolationModeHighQualityBicubic)
        .Show
    End With
End Sub

'昔shiraさんから教わったコード
'補間にInterpolationModeHighQualityBicubicを使用すると、左端・上端に灰色の線ができてしまう
'エクセルのワークシートで使用するには、白線の方が良いので、白色で事前に塗りつぶす様に
'改造させていただいている。

Public Function LoadPictureScaled( _
              ByVal FileName As String, _
              Optional ByVal scalerate As Long = 100, _
              Optional ByVal InterpolationMode As InterpolationMode _
                           = InterpolationModeBilinear _
              ) As stdole.IPictureDisp

    Dim IID_IDispatch As GUID
    Dim pd As PICTDESC
    Dim udtInput  As GdiplusStartupInput
    Dim objPicture As Object
    Dim hBmp As Long
    Dim lngToken  As Long
    Dim pGraphics As Long
    Dim pSrcBmp   As Long
    Dim pDstBmp   As Long
    Dim lngWidth  As Long, lngHeight As Long
    Dim dstwidth As Long, dstheight As Long
    Dim lngStatus As Long
    Dim hBrush As Long

    ' 初期化
    udtInput.GdiplusVersion = 1
    If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
        Exit Function
    End If

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

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

    If GdipGetImageGraphicsContext(pSrcBmp, pGraphics) = 0 Then
        ' コピー先Bitmap作成 lngWidth,lngHeigtになっていて、縮小時余黒？ができるので修正
        lngStatus = GdipCreateBitmapFromGraphics( _
                        dstwidth, dstheight, pGraphics, pDstBmp)

        GdipDeleteGraphics pGraphics

        If lngStatus = 0 Then
            ' コピー用Graphics作成
            If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
                ' 補間方法の設定
                GdipSetInterpolationMode pGraphics, InterpolationMode
                 '高画質バイキュービックのとき、縁が出来てしまうので白で塗りつぶしておく
                GdipCreateSolidFill &HFFFFFFFF, hBrush
                GdipFillRectangle pGraphics, hBrush, 0, 0, dstwidth, dstheight
                GdipDeleteBrush hBrush
                ' イメージのコピー
                GdipDrawImageRectI pGraphics, pSrcBmp, _
                                   0, 0, dstwidth, dstheight
                GdipDeleteGraphics pGraphics

                ' GDIのビットマップ作成
                GdipCreateHBITMAPFromBitmap pDstBmp, hBmp, 0
            End If
            GdipDisposeImage pDstBmp
        End If
    End If

    GdipDisposeImage pSrcBmp
    GdiplusShutdown lngToken
    If hBmp = 0 Then Exit Function

    ' 以降はOLEのPictureオブジェクト作成処理
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With pd
        .cbSizeofstruct = Len(pd)
        .picType = PICTYPE_BITMAP
        .hbitmap = hBmp
    End With
    If OleCreatePictureIndirect(pd, IID_IDispatch, _
                                1, objPicture) >= 0 Then
        Set LoadPictureScaled = objPicture
    Else
        ' エラー時
        DeleteObject hBmp
    End If

End Function
縮小率指定で画像を読み込んで、Pictureに変換する
