home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / Weather1888155132005.psc / modBytesToPicture.bas < prev    next >
BASIC Source File  |  2000-01-01  |  3KB  |  95 lines
  1. Attribute VB_Name = "modBytesToPicture"
  2. Option Explicit
  3.  
  4. Private Const S_OK As Long = 0&
  5.  
  6. Private Type UUID
  7.    Data1 As Long
  8.    Data2 As Integer
  9.    Data3 As Integer
  10.    Data4(7) As Byte
  11. End Type
  12.  
  13. Private Declare Function CreateStreamOnHGlobal Lib "ole32" _
  14.    (ByVal hGlobal As Long, _
  15.     ByVal fDeleteOnRelease As Long, _
  16.     ByRef ppstm As Any) As Long
  17.  
  18. Private Declare Function OleLoadPicture Lib "olepro32" _
  19.    (ByVal pStream As Long, _
  20.     ByVal lSize As Long, _
  21.     ByVal fRunmode As Long, _
  22.     ByRef riid As UUID, _
  23.     ByRef ppvObj As Any) As Long
  24.  
  25. Private Const GMEM_MOVEABLE As Long = &H2&
  26. Private Declare Function GlobalAlloc Lib "kernel32" _
  27.    (ByVal uFlags As Long, _
  28.     ByVal dwBytes As Long) As Long
  29.  
  30. Private Declare Function GlobalLock Lib "kernel32" _
  31.    (ByVal hMem As Long) As Long
  32.  
  33. Private Declare Function GlobalUnlock Lib "kernel32" _
  34.    (ByVal hMem As Long) As Long
  35.  
  36. Private Declare Function GlobalFree Lib "kernel32" _
  37.    (ByVal hMem As Long) As Long
  38.  
  39. Private Declare Sub RtlMoveMemory Lib "kernel32" _
  40.    (ByVal pDest As Long, _
  41.     ByRef pSource As Byte, _
  42.     ByVal dwLength As Long)
  43.  
  44. Public Function BytesToPicture(ByRef PicBin() As Byte) As Picture
  45.     Dim Low As Long, High As Long, Size As Long
  46.     Dim IID_IPicture As UUID
  47.     Dim oPicture As IPicture
  48.  
  49.     Low = LBound(PicBin)
  50.     High = UBound(PicBin)
  51.     Size = High - Low + 1
  52.  
  53.     '{7BF80980-BF32-101A-8BBB-00AA00300CAB}
  54.     With IID_IPicture
  55.         .Data1 = &H7BF80980
  56.         .Data2 = &HBF32
  57.         .Data3 = &H101A
  58.         .Data4(0) = &H8B
  59.         .Data4(1) = &HBB
  60.         .Data4(3) = &HAA
  61.         .Data4(5) = &H30
  62.         .Data4(6) = &HC
  63.         .Data4(7) = &HAB
  64.     End With
  65.  
  66.     Dim hMem As Long
  67.     Dim lpMem As Long
  68.     Dim lRet As Long
  69.     Dim Stm As IUnknown
  70.  
  71.     hMem = GlobalAlloc(GMEM_MOVEABLE, Size)
  72.     If hMem = 0 Then
  73.         Exit Function
  74.     End If
  75.  
  76.     lpMem = GlobalLock(hMem)
  77.     If lpMem <> 0 Then
  78.         RtlMoveMemory ByVal lpMem, PicBin(Low), Size
  79.         GlobalUnlock hMem
  80.         lRet = CreateStreamOnHGlobal(hMem, 1, Stm)
  81.         If lRet = S_OK Then
  82.             OleLoadPicture ObjPtr(Stm), Size, 0, IID_IPicture, oPicture
  83.         End If
  84.         GlobalFree hMem
  85.     End If
  86.     Set BytesToPicture = oPicture
  87.     Set oPicture = Nothing
  88. End Function
  89.  
  90. Public Function StringToPicture(ByVal Str As String) As Picture
  91.     Dim b() As Byte
  92.     b = StrConv(Str, vbFromUnicode)
  93.     Set StringToPicture = BytesToPicture(b)
  94. End Function
  95.