URLを指定してPNG画像を取り込む方法 (ID:125352)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

GDI+さん  するどい指摘ありがとうございました。
検索に没頭するあまり、URLOpenBlockingStream のことを
すっかり忘れていました。
URLOpenBlockingStream を使ってなんとか表示することができました。

以下ソースを貼りますので、怪しいところなどあったら
教えて下さい。

Option Explicit
Private Type tagPicBmp
    Size            As Long
    Type            As Long
    hBmp            As Long
    hPal            As Long
    Reserved        As Long
End Type

Private Type tagGUID
    Data1           As Long
    Data2           As Integer
    Data3           As Integer
    Data4(0 To 7)   As Byte
End Type
Private Declare Function GdipCreateBitmapFromStream Lib "gdiplus" ( _
        ByVal Stream As Long, bitmap As Long) As Long
Private Declare Function URLOpenBlockingStream Lib "urlmon" Alias "URLOpenBlockingStreamA" _
                                (ByVal pCaller As IUnknown, _
                                 ByVal szURL As String, _
                                 ppStream As Long, _
                                 ByVal dwResv As Long, _
                                 ByVal lpfnCB As IUnknown) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
                                (lpPictDesc As tagPicBmp, _
                                 riid As tagGUID, _
                                 ByVal fPictureOwnsHandle As Long, _
                                 ipic As IPicture) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" _
                                (ByVal hInst As Long, _
                                 ByVal lpszName As Long, _
                                 ByVal uType As Long, _
                                 ByVal cxDesired As Long, _
                                 ByVal cyDesired As Long, _
                                 ByVal fuLoad As Long) As Long
                                 Private Type GdiplusStartupInput
    GdiplusVersion              As Long
    DebugEventCallback          As Long
    SuppressBackgroundThread    As Long
    SuppressExternalCodecs      As Long
End Type
Private Declare Function GdiplusStartup Lib "gdiplus" _
                                (ByRef token As Long, _
                                 ByRef inputbuf As GdiplusStartupInput, _
                                 ByRef outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" _
                                (ByVal token As Long) As Long

Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
                                (ByVal filename As Long, _
                                 ByRef bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
                                (ByVal bitmap As Long, _
                                 ByRef hbmReturn As Long, _
                                 ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" _
                                (ByVal image As Long) As Long

Public Function URLLoadPNGPicture(ByVal strFileName As String) As Picture
    Dim gsi As GdiplusStartupInput
    Dim rslt As Long
    Dim lngGdiPlusTolen As Long
    Dim lngBitmap As Long
    Dim hBitmap As Long

' 構造体初期化
    With gsi
        .GdiplusVersion = 1
        .DebugEventCallback = 0
        .SuppressBackgroundThread = 0
        .SuppressExternalCodecs = 0
    End With

'GDI+初期化
    Dim oStream As Long
    rslt = GdiplusStartup(lngGdiPlusTolen, gsi, 0)
    If rslt = 0 Then
        'イメージファイルの読み込み
        rslt = URLOpenBlockingStream(Nothing, strFileName, oStream, 0, Nothing)
        If rslt = 0 Then
            'GDIビットマップを作成する。
            rslt = GdipCreateBitmapFromStream(oStream, lngBitmap)
            If rslt = 0 Then
                'GDIビットマップハンドルを作成する。
                rslt = GdipCreateHBITMAPFromBitmap(lngBitmap, hBitmap, 0)
            
                'ピクチャーオブジェクトに変換する処理。
                Set URLLoadPNGPicture = ConvertBitmap(hBitmap)
            
                '取得したイメージを開放する。
                Call GdipDisposeImage(lngBitmap)
            End If
        End If
        Call GdiplusShutdown(lngGdiPlusTolen)
    End If
    If rslt Then Err.Raise 481, , "エラー"
End Function

Private Sub Command1_Click()
    Dim urlName As String
    
    urlName = "http://www.libpng.org/pub/png/img_png/pnglogo-blk-sml1.png"
    Picture1.BorderStyle = 0    ' なし
    Picture1.AutoRedraw = True
    Set Picture1.Picture = URLLoadPNGPicture(urlName)

Exit Sub

通ってみたさん K.J.K.さん GDI+さん  ありがとうございました。

←解決時は質問者本人がここをチェックしてください。

戻る