VB如何用IPicture 来显示图片?

Dim RenICO As IPicture
Set RenICO = LoadResPicture(200, vbResIcon)'假设从资源文件提取
set picture1.picture=renico

Dim P_ICO As IPicture
Set P_ICO = LoadResPicture(200, vbResIcon)
set pit1.picture=P_ICO

picture1.picture=loadpicture("c:\1.bmp")

1.引用olelib.tlb
2.模块中贴入下面代码：
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) 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 Const PictureID = &H746C&
Private Type PictureHeader
    Magic As Long
    Size As Long
End Type Public Function Array2Picture(aBytes() As Byte) As IPicture
    Dim oIPS As IPersistStream
    Dim oStream As IStream
    Dim hGlobal As Long
    Dim LPTR As Long
    Dim lSize As Long
    Dim Hdr As PictureHeader



    lSize = UBound(aBytes) - LBound(aBytes) + 1
    hGlobal = GlobalAlloc(GHND, lSize + Len(Hdr))
    If hGlobal Then
        LPTR = GlobalLock(hGlobal)
        Hdr.Magic = PictureID
        Hdr.Size = lSize
        MoveMemory ByVal LPTR, Hdr, Len(Hdr)
        MoveMemory ByVal LPTR + Len(Hdr), aBytes(0), lSize
        GlobalUnlock hGlobal

        Set oStream = CreateStreamOnHGlobal(hGlobal, True)
        Set Array2Picture = New StdPicture
        Set oIPS = Array2Picture
        oIPS.Load oStream
        Set oStream = Nothing

    End If
End Function 3.用Array2Picture函数把字节流转换成图片我在数组里的是一个PNG格式的图片,调用上述方法后出现Automation error Catastrophic failure 的错误,
数组内容:
89 50 4E 47 0D 0A 1A 0A 00 00 00 0D 49 48 44 52 00 00 00 82 00 00 00 35 04 03 00 00 00 7F E2 2E 03 00 00 00 30 50 4C 54 45 FF FF FF EF EF EF 5F 5F 5F 8F 8F 8F BF BF BF 0F 0F 0F 3F 3F 3F 7F 7F 7F CF CF CF 2F 2F 2F DF DF DF 1F 1F 1F 65 9F 9F AF AF AF 4F 4F 4F 6F 6F 6F 03 A7 70 12 00 00 03 FB 49 44 41 54 78 9C ED 55 4D 88 5B 55 14 3E F9 6D 7E 67 B2 30 D0 D1 85 81 1A 5C 09 59 98 8D A0 04 64 16 0A 82 93 F8 A5 93 BC C9 8F E2 B3 42 15 06 71 FC 43 CA 74 11 CA 2C C4 F1 E7 0D 4A BB 88 E2 40 45 C4 5A 88 2B 7F 22 38 85 4A D5 D8 12 AA 2E 74 36 41 4A 45 67 13 50 91 C1 73 EE 7D EF E5 E5 39 A3 D0 A5 CC 59 BC 7B EF B9 E7 7C E7 FF 3E A2 03 3A A0 FF A4 CC 0D EA 1D 99 3F B6 F6 82 6C DE CB DD 88 3A F0 11 84 E8 9D 4B DF 15 1F DC 53 24 71 F5 5A 0F C6 23 85 BD EE DE 3F 71 9A 95 AF 02 26 7A 02 D3 D8 4B E8 B2 BA 02 1E DA E3 2E A9 8C 9F A5 D1 A9 14 1B 31 81 26 85 BF F4 C9 A4 47 A8 1D B9 3F 43 89 97 50 7D CE 0F 90 CE BF 7A E7 5B 7A 9B 6F 7E A3 EC 64 42 A8 FE B5 EA 91 79 19 B8 C3 CE EF 09 B6 36 4D 3F 96 BF 75 B6 73 18 50 8A 7D 40 9F DE E5 EF 2B AE CC 45 94 4B EE 21 86 CF 2E 3D 75 7C C9 3D 8E E1 E6 2D 60 2D 6A 0E DA B1 18 8C AF 0A 13 99 27 BC 36 9F 61 74 A3 EF 9C 22 B8 CD BD 89 42 B3 2F A0 B6 32 C3 C9 10 FA 35 43 4B 26 7E 77 65 C2 BF 48 4C 16 3E 74 18 A9 8D AD 09 76 B1 66 6F 3A 92 8B AA EC D2 58 25 18 7F F2 EE F0 95 5D 8B 97 59 43 DB 7D DC 51 6A AD 4E 00 02 A8 38 86 CA EC A8 82 4B 62 10 6C 7D 8F 4F 5F E4 52 1A 4F 33 23 AE FC 8C 61 3A 2E 61 9D 24 3A 84 FA 84 11 B6 94 B1 22 0A 69 A2 35 F6 A8 A7 6F 23 58 97 05 17 E0 35 2E CA 78 2D 70 0B BC BD 38 86 72 0B 3B 02 87 33 27 E7 74 9F 75 D4 12 A8 72 7D 6B 77 79 C4 CD D7 0F 8F 37 7A 1A DE A6 15 70 FD 83 06 B6 79 1F AA 0A 4A 53 3B 25 D1 C5 5A 24 65 3F E6 BA 11 42 97 73 66 4D 21 14 99 47 9D 5D C5 4B 4A 95 2D 61 50 7E 84 12 27 58 BA 21 F1 3C F0 B3 2D 1D 95 98 F3 53 08 61 53 24 8F DF AA 22 DB CA C9 47 05 B4 D1 41 9B A3 5E 54 42 A7 4C A7 3D 93 E2 F1 BC E9 C9 C3 65 2E E7 80 4D 85 54 FE AC AE CA A1 5C B7 A2 32 5A 41 47 F2 5E 7B 8D E3 61 A2 AC 89 05 FB 9C CE A3 B6 85 02 C5 D7 D3 22 9F 6E 09 73 16 EC 7A B8 A1 F2 11 3D 47 D3 94 82 31 A0 D8 08 DA B7 C0 D7 EC C0 42如何解决?

貌似VB的IPicture不支持PNG格式的图片,两种方法：
1.转换格式
2.用GDI+

picture1.picture=loadpicture("D:\1.bmp")
D:\1.bmp 图片存放的路径

将StdPicture写入Byte数组及读出
'--------------------------------------------------------
' Procedure : SaveImage
' Purpose   : Saves a StdPicture object in a byte array.
'--------------------------------------------------------
'
Public Function SaveImage( _
   ByVal image As StdPicture) As Byte()
Dim abData() As Byte
Dim oPersist As IPersistStream
Dim oStream As IStream
Dim lSize As Long
Dim tStat As STATSTG    ' Get the image IPersistStream interface
   Set oPersist = image

   ' Create a stream on global memory
   Set oStream = CreateStreamOnHGlobal(0, True)

   ' Save the picture in the stream
   oPersist.Save oStream, True

   ' Get the stream info
   oStream.Stat tStat, STATFLAG_NONAME

   ' Get the stream size
   lSize = tStat.cbSize * 10000

   ' Initialize the array
   ReDim abData(0 To lSize - 1)

   ' Move the stream position to
   ' the start of the stream
   oStream.Seek 0, STREAM_SEEK_SET

   ' Read all the stream in the array
   oStream.Read abData(0), lSize

   ' Return the array
   SaveImage = abData

   ' Release the stream object
   Set oStream = Nothing End Function '--------------------------------------------------------
' Procedure : LoadImage
' Purpose   : Creates a StdPicture object from a byte array.
'--------------------------------------------------------
'
Public Function LoadImage( _
   ImageBytes() As Byte) As StdPicture
Dim oPersist As IPersistStream
Dim oStream As IStream
Dim lSize As Long

   ' Calculate the array size
   lSize = UBound(ImageBytes) - LBound(ImageBytes) + 1

   ' Create a stream object
   ' in global memory
   Set oStream = CreateStreamOnHGlobal(0, True)

   ' Write the header to the stream
   oStream.Write &H746C&, 4&

   ' Write the array size
   oStream.Write lSize, 4&

   ' Write the image data
   oStream.Write ImageBytes(LBound(ImageBytes)), lSize

   ' Move the stream position to
   ' the start of the stream
   oStream.Seek 0, STREAM_SEEK_SET

   ' Create a new empty picture object
   Set LoadImage = New StdPicture

   ' Get the IPersistStream interface
   ' of the picture object
   Set oPersist = LoadImage

   ' Load the picture from the stream
   oPersist.Load oStream

   ' Release the streamobject
   Set oStream = Nothing

End Function

http://cnzx219.spaces.live.com/blog/cns!b181744d93a2b752!118.entry

vb 如何使用 PNG 透明格式的图片
Private Declare Function GdiplusStartup Lib "gdiplus.dll" ( _
     ByRef token As Long, _
     ByRef inputX As GdiplusStartupInput, _
     ByVal Output As Long _
     ) As Status

     Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)      Private Declare Function GdipCreateFromHDC Lib "gdiplus.dll" ( _
     ByVal hdc As Long, ByRef graphics As Long _
     ) As Status


     Private Declare Function GdipDrawImage Lib "gdiplus.dll" ( _
     ByVal graphics As Long, ByVal Image As Long, _
     ByVal X As Single, ByVal Y As Single _
     ) As Status

     Private Declare Function GdipLoadImageFromFile Lib "gdiplus.dll" ( _
     ByVal FileName As Long, ByRef Image As Long _
     ) As Status

Private Declare Function GdipDisposeImage Lib "gdiplus.dll" _
     (ByVal Image As Long) As Status需要声明的结构：     Private Type GdiplusStartupInput
     GdiplusVersion As Long
     DebugEventCallback As Long
     SuppressBackgroundThread As Long
     SuppressExternalCodecs As Long
     End Type具体做法如下：     Dim m_lngGraphics as long
     Dim m_lngInstance as long
     Dim m_lngPic as long     Private Sub Form_Load() 'GDI+初始化
     Dim udtData As GdiplusStartupInput

     Randomize

     udtData.GdiplusVersion = 1     If GdiplusStartup(app.hInstance, udtData, 0) Then
         MsgBox "GDI+ could not be initialized", vbCritical
         Exit Sub
     End If

     If GdipCreateFromHDC(Me.hdc, m_lngGraphics) Then
         MsgBox "Graphics object could not be created", vbCritical
         Exit Sub
     End If     GdipLoadimagefromfile "c:\1.png" , m_lngPic
     GdipImageDraw m_lngGraphics,m_lngPic
End Sub

从其他映象中取得:Dim RenICO As IPicture
Set RenICO = Image1.Picture
Set picture1.picture=renico

15楼的代码错误太多了下面这个可以运行Option Explicit
Private Type GdiplusStartupInput
   GdiplusVersion As Long              ' Must be 1 for GDI+ v1.0, the current version as of this writing.
   DebugEventCallback As Long          ' Ignored on free builds
   SuppressBackgroundThread As Long    ' FALSE unless you're prepared to call
                                       ' the hook/unhook functions properly
   SuppressExternalCodecs As Long      ' FALSE unless you want GDI+ only to use
                                       ' its internal image codecs.
End Type
Private Enum GpStatus   ' aka Status
   Ok = 0
   GenericError = 1
   InvalidParameter = 2
   OutOfMemory = 3
   ObjectBusy = 4
   InsufficientBuffer = 5
   NotImplemented = 6
   Win32Error = 7
   WrongState = 8
   Aborted = 9
   FileNotFound = 10
   ValueOverflow = 11
   AccessDenied = 12
   UnknownImageFormat = 13
   FontFamilyNotFound = 14
   FontStyleNotFound = 15
   NotTrueTypeFont = 16
   UnsupportedGdiplusVersion = 17
   GdiplusNotInitialized = 18
   PropertyNotFound = 19
   PropertyNotSupported = 20
End Enum
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As GpStatus
Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal graphics As Long, ByVal Image As Long, ByVal x As Single, ByVal y As Single) As GpStatus
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, graphics As Long) As GpStatus
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, Image As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As GpStatus
Dim gdip_Token As Long
Dim gdip_pngImage As Long
Dim gdip_Graphics As Long  Private Sub Form_Activate()
If GdipCreateFromHDC(Me.hDC, gdip_Graphics) <> Ok Then
    MsgBox "出现错误！", vbCritical, "错误"
    GdiplusShutdown gdip_Token
    End
End If  GdipLoadImageFromFile StrConv("C:\Show.png", vbUnicode), gdip_pngImage   '加载文件
End Sub  Private Sub Form_Load()
Dim GpInput As GdiplusStartupInput
GpInput.GdiplusVersion = 1  If GdiplusStartup(gdip_Token, GpInput) <> Ok Then
    MsgBox "加载GDI+失败！", vbCritical, "加载错误"
    End
End If
End Sub  Private Sub Form_Paint()
If GdipDrawImage(gdip_Graphics, gdip_pngImage, 0, 0) <> Ok Then Debug.Print "显示失败"
End Sub  Private Sub Form_Unload(Cancel As Integer)
GdipDisposeImage gdip_pngImage
GdipDeleteGraphics gdip_Graphics
GdiplusShutdown gdip_Token
End Sub  http://cache.baidu.com/c?word=gdiploadimagefromfile&url=http%3A//post%2Ebaidu%2Ecom/f%3Fkz%3D214574476&p=c27bd015d9c159fc57ee91275451&user=baidu

Option Explicit
Private Type GdiplusStartupInput
   GdiplusVersion As Long               ' Must be 1 for GDI+ v1.0, the current version as of this writing.
   DebugEventCallback As Long           ' Ignored on free builds
   SuppressBackgroundThread As Long     ' FALSE unless you 're prepared to call
                                        ' the hook/unhook functions properly
   SuppressExternalCodecs As Long       ' FALSE unless you want GDI+ only to use
                                        ' its internal image codecs.
End Type
Private Enum GpStatus    ' aka Status
   Ok = 0
   GenericError = 1
   InvalidParameter = 2
   OutOfMemory = 3
   ObjectBusy = 4
   InsufficientBuffer = 5
   NotImplemented = 6
   Win32Error = 7
   WrongState = 8
   Aborted = 9
   FileNotFound = 10
   ValueOverflow = 11
   AccessDenied = 12
   UnknownImageFormat = 13
   FontFamilyNotFound = 14
   FontStyleNotFound = 15
   NotTrueTypeFont = 16
   UnsupportedGdiplusVersion = 17
   GdiplusNotInitialized = 18
   PropertyNotFound = 19
   PropertyNotSupported = 20
End Enum
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As GpStatus
Private Declare Function GdipDrawImage Lib "GDIPlus" (ByVal graphics As Long, ByVal Image As Long, ByVal x As Single, ByVal y As Single) As GpStatus
Private Declare Function GdipCreateFromHDC Lib "GDIPlus" (ByVal hDC As Long, graphics As Long) As GpStatus
Private Declare Function GdipDeleteGraphics Lib "GDIPlus" (ByVal graphics As Long) As GpStatus
Private Declare Function GdipLoadImageFromFile Lib "GDIPlus" (ByVal filename As String, Image As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As GpStatus
Dim gdip_Token As Long
Dim gdip_pngImage As Long
Dim gdip_Graphics As Long
Private Sub Form_Activate()
If GdipCreateFromHDC(Me.hDC, gdip_Graphics) <> Ok Then
    MsgBox "出现错误！", vbCritical, "错误"
    GdiplusShutdown gdip_Token
    End
End If

    Dim oStream  As IStream
    Dim ImageBytes() As Byte
    Dim filename As String
    filename = App.Path & "\test.png"
    Open filename For Binary Access Read As #1
    ReDim ImageBytes(LOF(1) - 1)
    Get #1, , ImageBytes
    Close #1
    CreateStreamOnHGlobal ImageBytes(0), True, oStream
    Dim iStatus As GpStatus '
    iStatus = GdipLoadImageFromStream(oStream, gdip_pngImage) '加载文件
    Set oStream = Nothing'GdipLoadImageFromFile StrConv(App.Path & "\test.png", vbUnicode), gdip_pngImage    '加载文件
End SubPrivate Sub Form_Load()
Dim GpInput As GdiplusStartupInput
GpInput.GdiplusVersion = 1If GdiplusStartup(gdip_Token, GpInput) <> Ok Then
    MsgBox "加载GDI+失败！", vbCritical, "加载错误"
    End
End If
End SubPrivate Sub Form_Paint()
If GdipDrawImage(gdip_Graphics, gdip_pngImage, 0, 0) <> Ok Then Debug.Print "显示失败"
End SubPrivate Sub Form_Unload(Cancel As Integer)
GdipDisposeImage gdip_pngImage
GdipDeleteGraphics gdip_Graphics
GdiplusShutdown gdip_Token
End Sub15楼的方法修改了一下可以加载png数组了。
不过需要楼主下载一个 gdi+.tlb

调试易

VB如何用IPicture 来显示图片?

解决方案 »