VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. GDI+
  3. CBのbitmapをリサイズしてCBに書き戻す（その１）


クリップボードのbitmapをリサイズしてクリップボードに書き戻す（テンポラリファイル使用版）

テンポラリファイル不使用版を作成できたので、不必要であるが、
画像をADODB.Stream経由で読込む事例として残しておきます


Public Enum InterpolationMode   ' 補間方法
    InterpolationModeInvalid = -1
    InterpolationModeDefault = 0
    InterpolationModeLowQuality = 1
    InterpolationModeHighQuality = 2
    InterpolationModeBilinear = 3
    InterpolationModeBicubic = 4
    InterpolationModeNearestNeighbor = 5
    InterpolationModeHighQualityBilinear = 6
    InterpolationModeHighQualityBicubic = 7
End Enum
Private Type GdiplusStartupInput
    GdiplusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
    cbSizeofStruct As Long
    picType As Long
    hbitmap As Long
    hpal As Long
    unused_wmf_yExt As Long
End Type

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Const PICTYPE_BITMAP = 1

Private Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_READ  As Long = &H80000000
Private Const CREATE_ALWAYS = &H2
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20

Private Const UnitWorld = 0      ' World coordinate (non-physical unit)
Private Const UnitDisplay = 1    ' Variable -- for PageTransform only
Private Const UnitPixel = 2      ' Each unit is one device pixel.
Private Const UnitPoint = 3      ' Each unit is a printer's point, or 1/72 inch.
Private Const UnitInch = 4       ' Each unit is 1 inch.
Private Const UnitDocument = 5   ' Each unit is 1/300 inch.
Private Const UnitMillimeter = 6 ' Each unit is 1 millimeter.

Private Const PixelFormatIndexed As Long = &H10000        ' Indexes into a palette
Private Const PixelFormatGDI As Long = &H20000            ' Is a GDI-supported format
Private Const PixelFormatAlpha As Long = &H40000          ' Has an alpha component
Private Const PixelFormatPAlpha As Long = &H80000         ' Pre-multiplied alpha
Private Const PixelFormatExtended As Long = &H100000      ' Extended color 16 bits/channel
Private Const PixelFormatCanonical As Long = &H200000
Private Const PixelFormatUndefined As Long = 0
Private Const PixelFormatDontCare As Long = 0

'追加分　クリップボード操作
Private Const CF_BITMAP As Long = 2
Private Const CF_DIB = 8

Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef ppstm As Any) As Long
Private Const GMEM_MOVEABLE As Long = &H2&
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal pDest As Long, ByVal pSource As Long, ByVal dwLength As Long)

Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpszName As String, ByVal dwAccess As Long, _
    ByVal dwShareMode As Long, ByVal lpsa As Long, _
    ByVal dwCreate As Long, ByVal dwAttrsAndFlags As Long, _
    ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WriteFile Lib "kernel32" ( _
    ByVal hFile As Long, ByRef lpBuffer As Any, _
    ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, _
    ByVal lpOverlapped As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
    ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GetClipboardData Lib "user32" ( _
    ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long

'GDI+開始
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, pInput As GdiplusStartupInput, _
        pOutput As Any) As Long
'GDI+終了
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
'デバイスコンテキストからGraphicsを生成
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, graphics As Long) As Long
'Graphics削除
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
'補間モード設定
Private Declare Function GdipSetInterpolationMode Lib "gdiplus" (ByVal graphics As Long, _
        ByVal nInterpolationMode As InterpolationMode) As Long
'Image削除
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
'Imageの寸法取得
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
'Graphicsのサイズに合わせてImage描画
Private Declare Function GdipDrawImageRectI Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, _
        ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long) As Long
'ファイルからBitmap取得
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (FileName As Any, bitmap As Long) As Long
'GraphicsからBitmap取得
Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, _
        ByVal Target As Long, bitmap As Long) As Long
'BitmapをHBITMAPに変換、クリップボードへの貼り付けに必要
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As Long, hbmReturn As Long, _
        ByVal background As Long) As Long
'OleStdPictureの生成
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (lpPictDesc As PICTDESC, riid As GUID, _
        ByVal fOwn As Long, lplpvObj As Any) As Long
'Objectの削除
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GdipCreateSolidFill Lib "gdiplus.dll" (ByVal pColor As Long, ByRef brush As Long) As Long
'塗りつぶし四角形を描画
Private Declare Function GdipFillRectangle Lib "gdiplus.dll" (ByVal graphics As Long, ByVal brush As Long, ByVal X As Single, ByVal Y As Single, ByVal nWidth As Single, ByVal nHeight As Single) As Long
'GDI+のブラシ削除
Private Declare Function GdipDeleteBrush Lib "gdiplus.dll" (ByVal brush As Long) As Long

Private Declare Function GdipCreateFromHDC Lib "gdiplus" ( _
        ByVal hdc As Long, graphics As OLE_HANDLE) As Long
'Streamからイメージ生成
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" _
   (ByVal stm As Long, _
    ByRef img As OLE_HANDLE) As Long

Sub test()
    Dim lngRet As Long
    lngRet = SaveClipboardDIB("c:\temp.bmp")
    Call LoadPictureScaled2("c:\temp.bmp", Range("a2").Value)
    Kill "c:\temp.bmp" 'GdipCreateBitmapFromFileだとファイルがロックされてしまう
    ActiveSheet.Paste
End Sub

'ファイルロックを防ぐため、streamからの読込に変更
'http://www.vb-user.net/junk/replySamples/2007.10.21.12.01/DrawFromStream.txt
Private Sub LoadPictureScaled2( _
              ByVal FileName As String, _
              Optional ByVal outputHeight As Long = 240, _
              Optional ByVal InterpolationMode As InterpolationMode = InterpolationModeBilinear _
              )
              
    Dim IID_IDispatch As GUID
    Dim pd As PICTDESC
    Dim udtInput  As GdiplusStartupInput
    Dim hBmp As Long
    Dim lngToken  As Long
    Dim pGraphics As Long
    Dim pSrcBmp   As Long
    Dim pDstBmp   As Long
    Dim lngWidth  As Long
    Dim lngHeight As Long
    Dim lngStatus As Long
    Dim hBrush As Long
    Dim aspectRatio As Double
    
    Dim bin() As Byte
    Dim size As Long
    Dim ptr As Long
    Dim stm As Object
    Dim ret As Long
    
    Dim ghMem As Long
    Dim gImg As OLE_HANDLE
    
    Const adTypeBinary As Long = 1
    Const adReadAll As Long = -1
    
    ' 初期化
    udtInput.GdiplusVersion = 1
    If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
        Exit Sub
    End If
    'ADODBでバイナリーで読み込んだStreamから画像生成
    With CreateObject("ADODB.Stream")
        .Type = adTypeBinary
        .Open
        .LoadFromFile FileName
        bin = .Read(adReadAll)
        .Close
    End With
    size = UBound(bin) + 1
    ghMem = GlobalAlloc(GMEM_MOVEABLE, size)
    ptr = GlobalLock(ghMem)
    RtlMoveMemory ptr, VarPtr(bin(0)), size
    ret = GlobalUnlock(ghMem)

    ret = CreateStreamOnHGlobal(ghMem, 1, stm)
    ret = GdipLoadImageFromStream(ObjPtr(stm), pSrcBmp)
    Set stm = Nothing
    
    ' 元画像サイズの取得
    GdipGetImageWidth pSrcBmp, lngWidth
    GdipGetImageHeight pSrcBmp, lngHeight
    aspectRatio = lngWidth / lngHeight
    ' サイズの変更
    lngHeight = outputHeight
    lngWidth = CLng(outputHeight * aspectRatio)
    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
                '縁が出来てしまうので白で塗りつぶしておく2010/2/5
                GdipCreateSolidFill &HFFFFFFFF, hBrush
                GdipFillRectangle pGraphics, hBrush, 0, 0, lngWidth, lngHeight
                GdipDeleteBrush hBrush
                ' イメージのコピー
                GdipDrawImageRectI pGraphics, pSrcBmp, 0, 0, lngWidth, lngHeight
                GdipDeleteGraphics pGraphics
                ' GDIのビットマップ作成
                GdipCreateHBITMAPFromBitmap pDstBmp, hBmp, 0
            End If
            GdipDisposeImage pDstBmp
        End If
    End If
    GdipDisposeImage pSrcBmp
    GdiplusShutdown lngToken
    If hBmp = 0 Then Exit Sub
    '画像をクリップボードにコピー
    If OpenClipboard(0) <> 0 Then
        EmptyClipboard
        SetClipboardData CF_BITMAP, hBmp
        CloseClipboard
    End If
End Sub

'クリップボードの画像（DIB情報）をBMP形式で保存
Public Function SaveClipboardDIB(ByVal sFileName As String) As Long
    Dim bmi As BITMAPINFOHEADER
    Dim bmh(0 To 7) As Integer
    Dim hFile As Long, iWritten As Long
    Dim hglb As Long, iMemSize As Long
    Dim lpBuffer As Long, iDIBSize As Long
    Dim ret As Long
    Dim i As Long
    
    'On Error GoTo ErrorHandler1
    'クリップボードのオープン
    If OpenClipboard(0) = 0 Then Exit Function
    'DIBのメモリハンドルを取得
    hglb = GetClipboardData(CF_DIB)
    If hglb = 0 Then GoTo exit_CloseClipboard
    'グローバルメモリのロック
    lpBuffer = GlobalLock(hglb)
    If lpBuffer = 0 Then GoTo exit_CloseClipboard
    If lpBuffer < 0 Then GoTo exit_GlobalUnlock
    'グローバルメモリのサイズのチェック
    iMemSize = GlobalSize(hglb)
    If iMemSize > 10000000 Then GoTo exit_GlobalUnlock
    If iMemSize < 16 Then GoTo exit_GlobalUnlock
    'BITMAPINFOHEADERの取得
    MoveMemory bmi, ByVal lpBuffer, 4
    MoveMemory bmi, ByVal lpBuffer, bmi.biSize
    iDIBSize = iMemSize
    'BITMAPFILEHEADERの作成
    bmh(0) = &H4D42
    i = 14 + iDIBSize
    MoveMemory bmh(1), i, 4
    i = 14 + bmi.biSize '
    MoveMemory bmh(5), i, 4
    'ファイルの作成
    hFile = CreateFile(sFileName, GENERIC_WRITE, 0, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_ARCHIVE, 0)
    ret = WriteFile(hFile, bmh(0), 14, iWritten, 0)
    ret = WriteFile(hFile, ByVal lpBuffer, iDIBSize, iWritten, 0)
    If ret = 0 Then GoTo exit_CloseFile
    ret = CloseHandle(hFile)
    If ret = 0 Then GoTo exit_GlobalUnlock
    hFile = 0
    ret = GlobalUnlock(hglb)
    If ret <> 0 Then GoTo exit_CloseClipboard
    hglb = 0
    ret = CloseClipboard()
    Exit Function
exit_CloseFile:
    ret = CloseHandle(hFile)
    hFile = 0
exit_GlobalUnlock:
    ret = GlobalUnlock(hglb)
    hglb = 0
exit_CloseClipboard:
    ret = CloseClipboard()
    Exit Function
exit_Function:
    Exit Function
ErrorHandler1:
    If (hFile <> 0) And (hFile <> INVALID_HANDLE_VALUE) Then ret = CloseHandle(hFile)
    If hglb Then ret = GlobalUnlock(hglb)
    ret = CloseClipboard()
    Exit Function
End Function