Here is a quick shot at it for you
Very little error checking and documentation - but for a quick example of how you can do this, it should be enough.
With this sample, you will have to customise the hard coded directory names. To be robust, you should add error checking and possibly a method to allow a bitmap to be removed from the resource file. That's easy to do but if you get stuck, just ask.
The sample lets you select bitmaps to load into the resource file (maximum of 100 entries). Then, by entering an index in the text box and clicking a button, the picture box will be loaded with the bitmap file. A temp file of c:\tmp.bmp is used. It will work with any bitmap that SavePicture likes.
You can also make a dll out of the class if you want, then all your apps can use "resource files" you create.
Good luck. Let me know if you have any problems.
Code:
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 4455
ClientLeft = 60
ClientTop = 345
ClientWidth = 6000
LinkTopic = "Form1"
ScaleHeight = 4455
ScaleWidth = 6000
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command2
Caption = "Command2"
Height = 375
Left = 120
TabIndex = 6
Top = 3840
Width = 1695
End
Begin VB.TextBox Text1
Height = 285
Left = 2880
TabIndex = 4
Text = "1"
Top = 3240
Width = 1095
End
Begin VB.CommandButton Command1
Caption = "Get"
Height = 375
Left = 4080
TabIndex = 2
Top = 3240
Width = 615
End
Begin VB.PictureBox Picture1
Height = 2775
Left = 2520
ScaleHeight = 2715
ScaleWidth = 2955
TabIndex = 1
Top = 240
Width = 3015
End
Begin VB.FileListBox File1
Height = 2820
Left = 120
TabIndex = 0
Top = 240
Width = 1695
End
Begin VB.Label Label2
Caption = "Type in index number and click get to see the bitmap"
Height = 375
Left = 2880
TabIndex = 5
Top = 3840
Width = 2055
End
Begin VB.Label Label1
Caption = "double click to add to resource file"
Height = 495
Left = 120
TabIndex = 3
Top = 3120
Width = 1695
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim myResfile As pclResFile
Private Sub Command1_Click()
With myResfile
Set Picture1 = .GetBitmap(Text1)
End With
End Sub
Private Sub Command2_Click()
myResfile.PrintHeader
End Sub
Private Sub File1_DblClick()
With myResfile
.OpenFile "d:\!dev\vb-world\resfile\myfile.res"
If .AddBitmap(File1.List(File1.ListIndex)) Then
Debug.Print "OK"
Else
Debug.Print "problem"
End If
End With
End Sub
Private Sub Form_Load()
Set myResfile = New pclResFile
With myResfile
.OpenFile "d:\!dev\vb-world\resfile\myfile.res"
End With
File1.path = "d:\!dev\bitmaps"
End Sub
Private Sub Form_Unload(Cancel As Integer)
With myResfile
.CloseFile
End With
End Sub
and the class
Code:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "pclResFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Const MAX_ENTRIES = 100
Private Const RES_NO_SPACE = -1
Private Type ResInfo
resType As Integer
resSize As Long
resOffset As Long
End Type
Private Enum ResTypes
resEmpty = 0
resBitmap = 1
End Enum
Private Type ResFile
resData(1 To MAX_ENTRIES) As ResInfo
End Type
Dim mOffset As Long
Dim mFilename As String
Dim mResFile As ResFile
Dim hFile As Long
Dim mNextEntry As Integer
Public Sub OpenFile(file As String)
' note: no error checking - need to add this if you want to rely on the class
mFilename = file
If hFile <> 0 Then Close #hFile
hFile = FreeFile
Open mFilename For Binary As #hFile
Get #hFile, , mResFile
GetFirstFreeEntry
End Sub
Public Sub CloseFile()
If hFile <> 0 Then
Put #hFile, 1, mResFile
Close #hFile
End If
End Sub
Public Function AddBitmap(bitmapFile As String) As Boolean
If hFile = 0 Then
MsgBox "No resource file open"
Exit Function
End If
' now get the bytes of the pic
' could do this with CDIBSection instead but that would add alot
' more complexity for now.
Dim f As Long
f = FreeFile
Dim mBytes() As Byte
ReDim mBytes(FileLen(bitmapFile) - 1)
Open bitmapFile For Binary As #f
Get #f, , mBytes
Close #f
' now store it
Dim myResIndex As Integer
Dim newOffset As Long
myResIndex = GetFirstFreeEntry
If myResIndex <> RES_NO_SPACE Then
With mResFile.resData(myResIndex)
.resSize = UBound(mBytes) + 1
.resType = ResTypes.resBitmap
' offset from end of header
newOffset = .resOffset + .resSize
End With
If myResIndex + 1 < MAX_ENTRIES Then
' set the offset for the next entry
With mResFile.resData(myResIndex + 1)
.resOffset = newOffset
End With
End If
AddBitmap = True
Else
MsgBox "Cannot store bitmap because there is no more space in the res file"
End If
' now we know where in the file to store data
Put #hFile, 1, mResFile
Put #hFile, mOffset + mResFile.resData(myResIndex).resOffset, mBytes
End Function
Public Function GetBitmap(index As Integer) As StdPicture
If hFile = 0 Then
MsgBox "No resource file open"
Exit Function
End If
Dim f As Long
f = FreeFile
Dim mBytes() As Byte
If index < 1 Or index > MAX_ENTRIES Then
MsgBox "Bad index"
Exit Function
End If
With mResFile.resData(index)
If .resSize = 0 Then
MsgBox "Bad res size"
Exit Function
End If
ReDim mBytes(.resSize)
Get #hFile, .resOffset + mOffset, mBytes
Open "c:\tmp.bmp" For Binary As #f
Put #f, , mBytes
Close #f
Dim myPic As StdPicture
On Error Resume Next
Set myPic = LoadPicture("c:\tmp.bmp")
'kill "c:\tmp.bmp"
On Error GoTo 0
End With
Set GetBitmap = myPic
End Function
Private Function GetFirstFreeEntry() As Integer
' loops through the entries and finds a space.
mNextEntry = RES_NO_SPACE
Dim c As Integer
For c = 1 To MAX_ENTRIES
If mResFile.resData(c).resType = ResTypes.resEmpty Then
' found one
mNextEntry = c
Exit For
End If
Next
If mNextEntry = 1 Then
mResFile.resData(1).resOffset = 1
End If
GetFirstFreeEntry = mNextEntry
End Function
Private Sub Class_Initialize()
' offset of the header
mOffset = Len(mResFile)
End Sub
Private Sub Class_Terminate()
If hFile <> 0 Then Close #hFile
End Sub
Public Sub PrintHeader()
Dim c As Integer
For c = 1 To MAX_ENTRIES
Debug.Print c, mResFile.resData(c).resType, mResFile.resData(c).resOffset, mResFile.resData(c).resSize
Next
End Sub
