GDIplusCODE


出典
http://www.tek-tips.com/viewthread.cfm?qid=1585878&page=38
元々はUserFormのImageコントロール経由で拡大縮小する関数であるが、
倍率指定で、ユーザーフォーム無しで実行できる様に、アレンジしてある。

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Sub CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any)
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicArray As Any, RefIID As Any, ByVal OwnsHandle As Long, IPic As Any) As Long

Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Private Const StdPicGUID As String = "{00020400-0000-0000-C000-000000000046}"

'拡大、縮小とも、Vixの3次元補間と比べてあまり差は感じられない
Sub ResizeAndSaveBmp()
    Dim myDC As Long
    Dim OldBMP As Long
    Dim myBMP As Long
    Dim srcIPicture As stdole.IPicture
    Dim NewWidth As Long, NewHeight As Long
    Dim srcFileName As String, dstFileName As String
    'http://msdn.microsoft.com/en-us/library/ms680761
    'http://msdn.microsoft.com/en-us/library/ms680762
    Dim dstPicture As stdole.IPicture
    
    Dim pd As PictDesc
    Dim IPic(15) As Byte
    Dim ratio As Double
    
    ratio = 2
    srcFileName = "C:\test96.bmp"
    dstFileName = "c:\test96_2.bmp"
  ' get different interface to the picture object
    Set srcIPicture = LoadPicture(srcFileName)
    'Debug.Print srcIPicture.Type 1:Bitmap
    '.Width : HIMETRIC, NewWidth : Pixel
    '96dpi決め打ち
    With srcIPicture
      NewWidth = (96 * (.Width / 100) / 25.4) * ratio
      NewHeight = (96 * (.Height / 100) / 25.4) * ratio
    End With
    myDC = CreateCompatibleDC(GetDC(0&))
    myBMP = CreateCompatibleBitmap(GetDC(0&), NewWidth, NewHeight)
    OldBMP = SelectObject(myDC, myBMP)
    With srcIPicture
       ' .Render hdc as Long,x as Long ,y as Long,cs as Long,cy as Long,xSrc as OLE_POS_HIMETRIC,ySrc as OLE_YPOS_HIMETRIC,cxSrc as OLE_XSIZE_HIMETRIC,cySrc as OLE_YSIZE_HIMETRIC,prcWBounds as Any)
        .Render myDC, 0, 0, NewWidth, NewHeight, 0, .Height, .Width, -.Height, ByVal 0&
    End With
    
    ' We now have a bitmap in myDC with the resized picture, whcih we want to be able to save
    ' so we can leverage the SavePicture method if we can turn that into a StdPic
    pd.cbSizeofStruct = Len(pd)
    pd.picType = 1
    pd.hImage = myBMP
    CLSIDFromString StrPtr(StdPicGUID), IPic(0)
    OleCreatePictureIndirect pd, IPic(0), True, dstPicture
    SavePicture dstPicture, dstFileName
    If dstPicture.handle = 0 Then MsgBox "Failed"
End Sub
stdole.IPictureのRenderメソッドを用いて、画像を拡大縮小する
