'****************************************************************
' Name : CResLoader
' Date : 2006-06-25
' Type : Class
' By : Muhammed Al Ansari
'****************************************************************
'Use Example:
'Private Sub Command1_Click()
'Dim X As New CResLoader
'Text1 = X.ReadResTextFile(103, "TEXTFILE")
'Me.Picture1 = X.ReadImage(101, "JPG")
'End Sub
'****************************************************************
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long
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 Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Function PictureFromByteStream(B() As Byte) As IPicture
Dim LowerBound As Long
Dim ByteCount As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture(15)
Dim istm As stdole.IUnknown
On Error GoTo Err_Init
If UBound(B, 1) < 0 Then
Exit Function
End If
LowerBound = LBound(B)
ByteCount = (UBound(B) - LowerBound) + 1
hMem = GlobalAlloc(&H2, ByteCount)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
MoveMemory ByVal lpMem, B(LowerBound), ByteCount
Call GlobalUnlock(hMem)
If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream)
End If
End If
End If
End If
Exit Function
Err_Init:
If Err.Number = 9 Then
'Uninitialized array
MsgBox "You must pass a non-empty byte array to this function!"
Else
MsgBox Err.Number & " - " & Err.Description
End If
End Function
Function ReadImage(ID As Long, Optional Folder As String = "CUSTOM") As IPicture
Dim B() As Byte
B = LoadResData(ID, Folder)
Set ReadImage = PictureFromByteStream(B)
End Function
Function ReadResTextFile(ID As Long, Optional Folder As String = "CUSTOM") As String
'****************************************************************
' Name : ReadResTextFile
' Date : 2006-06-24
' Type : Function
' By : Muhammed_KSA [Muhammed Al Ansari]
'****************************************************************
' This Function Is To Read Any TextFile Directly [*.txt;*.CSV;..]
' From Resource File !
'****************************************************************
'Declaration
Dim B() As Byte
Dim I As Long
Dim BufferText As String
'Definition
B = LoadResData(ID, Folder)
For I = 0 To UBound(B)
BufferText = BufferText & StrConv(ChrB(B(I)), vbUnicode)
Next I
ReadResTextFile = BufferText
End Function