|
6#
楼主 |
发表于 2011-7-19 11:03:08
|
只看该作者
贴一段读图片的代码:
- Option Compare Database
- Option Explicit
- Private Const S_OK = 0 ' indicates successful HRESULT
- Private Const sIID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
- Private Const GMEM_MOVEABLE = &H2
- Private Type GUID ' 16 bytes (128 bits)
- dwData1 As Long ' 4 bytes
- wData2 As Integer ' 2 bytes
- wData3 As Integer ' 2 bytes
- abData4(7) As Byte ' 8 bytes, zero based
- End Type
- Public Enum CBoolean ' enum members are Long data types
- CFalse = 0
- CTrue = 1
- End Enum
- Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes 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 Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
- Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pCLSID As GUID) As Long
- Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As CBoolean, riid As GUID, ppvObj As Any) As Long
- Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As CBoolean, ppstm As Any) As Long
- Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
- Public Function PictureFromBits(abPic() As Byte) As IPicture ' not a StdPicture!!
- Dim nLow As Long, cbMem As Long, hMem As Long
- Dim lpMem As Long, IID_IPicture As GUID
- Dim IStm As stdole.IUnknown, IPic As IPicture
- ' Get the size of the picture's bits
- On Error GoTo Out
- nLow = LBound(abPic)
- On Error GoTo 0
- cbMem = (UBound(abPic) - nLow) + 1
- ' Allocate a global memory object
- hMem = GlobalAlloc(GMEM_MOVEABLE, cbMem)
- If hMem Then
- ' Lock the memory object and get a pointer to it.
- lpMem = GlobalLock(hMem)
- If lpMem Then
- ' Copy the picture file bytes to the memory pointer
- ' and unlock the handle.
- MoveMemory ByVal lpMem, abPic(nLow), cbMem
- Call GlobalUnlock(hMem)
- ' Create an ISteam from the pictures bits (we can
- ' explicitly free hMem below, but we'll have the
- ' call do it here...)
- If (CreateStreamOnHGlobal(hMem, CTrue, IStm) = S_OK) Then
- If (CLSIDFromString(StrPtr(sIID_IPicture), _
- IID_IPicture) = S_OK) Then
- ' Create an IPicture from the IStream (the docs
- ' say the call does not AddRef its last param, but
- 'it looks like the reference counts are correct..)
- Call OleLoadPicture(ByVal ObjPtr(IStm), cbMem, CFalse, IID_IPicture, PictureFromBits)
- End If ' CLSIDFromString
- End If ' CreateStreamOnHGlobal
- End If ' lpMem
- Call GlobalFree(hMem)
- End If ' hMem
- Out:
- End Function
- 'With Form Inet1 Control
- 'Private Function GetPicFromHTTP(strURL As String, Optional Username As String, Optional Password As String) As IPicture
- ' Dim bytearray() As Byte
- '
- ' Inet1.URL = strURL
- ' Inet1.Username = Username
- ' Inet1.Password = Password
- ' bytearray() = Inet1.OpenURL(, icByteArray)
- '
- ' Set GetPicFromHTTP = PictureFromBits(bytearray)
- '
- 'End Function
- '
- 'Private Sub Command1_Click()
- ' Picture1.Picture = GetPicFromHTTP("http://msdn.microsoft.com/library/shared/toolbar/graphics/banners/MSDN_banner.gif";) '("http://www.wandtv.com/rdrimg.jpg";)
- 'End Sub
- Public Function LoadPictureFromField(f As ADODB.field) As StdPicture
- Dim b1() As Byte
-
- If f.ActualSize <> 0 Then
- ReDim b1(1 To f.ActualSize) As Byte
- b1 = f.GetChunk(f.ActualSize)
- Set LoadPictureFromField = PictureFromBits(b1)
- End If
- End Function
- Public Function LoadPictureFromFile(filePath As String) As StdPicture
- Dim b1() As Byte
-
- Open filePath For Binary As #1
- ReDim b1(1 To LOF(1))
- Get 1, , b1
- Close 1
-
- Set LoadPictureFromFile = PictureFromBits(b1)
- End Function
复制代码
|
|