GDIplusCODE


Private Sub LoadPictureScaledandRotated( _
              ByVal FileName As String, _
              Optional ByVal scalerate As Long = 100, _
              Optional ByVal InterpolationMode As InterpolationMode = InterpolationModeBilinear, _
              Optional ByVal angle As Single = 0 _
              )

    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
    Dim lngHeight As Long
    Dim lngStatus As Long
    Dim pImageTemp 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
    '画像の回転
    Call RotateImage(pSrcBmp, pImageTemp, angle, &HFFFFFFFF)
'    pImageTemp = pSrcBmp 'for debug
    ' 元画像サイズの取得
    GdipGetImageWidth pImageTemp, lngWidth
    GdipGetImageHeight pImageTemp, lngHeight
    ' サイズの変更
    lngWidth = lngWidth * scalerate \ 100
    lngHeight = lngHeight * scalerate \ 100
    If GdipGetImageGraphicsContext(pImageTemp, 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
                '縁が出来てしまうので白で塗りつぶしておく
                GdipCreateSolidFill &HFFFFFFFF, hBrush
                GdipFillRectangle pGraphics, hBrush, 0, 0, lngWidth, lngHeight
                GdipDeleteBrush hBrush
                ' イメージのコピー
                GdipDrawImageRectI pGraphics, pImageTemp, 0, 0, lngWidth, lngHeight
                GdipDeleteGraphics pGraphics
                ' GDIのビットマップ作成
                GdipCreateHBITMAPFromBitmap pDstBmp, hBmp, 0
            End If
            GdipDisposeImage pDstBmp
        End If
    End If
    GdipDisposeImage pImageTemp
    GdiplusShutdown lngToken
    If hBmp = 0 Then Exit Sub
    '画像をクリップボードにコピー
    If OpenClipboard(0) <> 0 Then
        EmptyClipboard
        SetClipboardData CF_BITMAP, hBmp
        CloseClipboard
    End If
End Sub
画像をリサイズ、回転してクリップボードにコピー【XL2010 CBにcopy失敗->対応code部屋】
