现在我定义一个资源包可以把别的文件都打包进来，如果要调用其中的一个文件，可以直接从这个包里面读取，当然也可以增加删除其中的文件，请问如何实现呢？取得文件：LoadRes(fileID) fileID为文件在资源包中的ID操作资源包：CreatRes(fileID,filename,Key) filename为文件名称；Key=0,增加文件到资源包，=1，删除文件到资源包（此时filename为“0”，因为在资源包中无需文件名）请问如何实现呢？
原贴（100）：http://community.csdn.net/Expert/TopicView.asp?id=3844211
原贴（100）：http://community.csdn.net/Expert/TopicView.asp?id=3844211
Test目录中的代码大概就是你想要的。
初步成果是这样的：（如果楼主尚且熟悉一点Byte操作，现在应该可以用了。要知道：文件=Bytes，Bytes=文件。）Private Sub Command5_Click()
Dim tPackBytes() As Byte
Dim tBytes() As Byte
Dim tOutRecHead(1) As tpRecHead
tBytes() = "playzwd (沙漠绿洲)是个大懒虫"
tOutRecHead(0) = BytesAppendToPackBytes(tPackBytes(), tBytes(), 1) '将一组Bytes追加到包。
tBytes() = "小仙妹是个好孩子"
tOutRecHead(1) = BytesAppendToPackBytes(tPackBytes(), tBytes(), 2) '将一组Bytes追加到包。 Text1.Text = BytesGetByPackBytes(tPackBytes(), tOutRecHead(0)) '读第一个包（注意：序号仅仅是记录顺序号，不是记录编号。）
Text2.Text = BytesGetByPackBytes(tPackBytes(), tOutRecHead(1)) '读第二个包
'Text1.Text = Len(tOutRecHead(1))
End Sub
modFilePack.bas文件内容Public Declare Sub BytesCopy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Type tpFileHead
fhRecCount As Long '记录数量（从1计算）
fhRecHeads As Long '记录头指针
fhDatas As Long '数据区指针
End TypeType tpRecHead
rhIndex As Long '记录索引号
rhEnabled As Boolean '记录有效
rhDatas As Long '数据指针
rhCount As Long '数据长度
End TypeType tpFilePack
fpFileHead As tpFileHead
fpRecHeads() As tpRecHead
fpDatas() As Byte
End TypeConst conFilePack_FileHeadLen As Long = 12
Const conFilePack_RecHeadLen As Long = 14Function RecHeadsGetToByte() As tpRecHeadEnd FunctionFunction RecHeadsPutToByte() As ByteEnd FunctionFunction BytesGetByPackBytes(ByRef pPackBytes() As Byte, ByRef pRecHead As tpRecHead) As Byte()
Dim tOutBytes() As Byte
Dim tRecStart As Long
Dim tRecCount As Long
Dim tRecEnabled As Long
With pRecHead
tRecStart = .rhDatas
tRecCount = .rhCount
tRecEnabled = .rhEnabled
End With
If tRecEnabled Then
tOutBytes() = BytesGetByBytes(pPackBytes(), tRecStart, tRecCount)
End If
BytesGetByPackBytes = tOutBytes()
End FunctionFunction BytesAppendToPackBytes(ByRef pPackBytes() As Byte, ByRef pBytes() As Byte, Optional ByVal pIndex As Long = 0) As tpRecHead
Dim tOutRecHead As tpRecHead
Dim tDesBytes_Count As Long
Dim tSurBytes_Count As Long
Dim tSurBytes_Enabled As Long
tSurBytes_Count = BytesCount(pBytes())
tSurBytes_Enabled = CBool(tSurBytes_Count)
If tSurBytes_Enabled Then
tDesBytes_Count = BytesCount(pPackBytes())
Dim tCopyStart As Long
Dim tCopyGood As Boolean
tCopyStart = BytesAppendToBytes(pPackBytes(), pBytes())
tCopyGood = CBool(tCopyStart) Or (Not (CBool(tDesBytes_Count) Or CBool(tCopyStart)))
With tOutRecHead
.rhIndex = pIndex
.rhCount = tSurBytes_Count
.rhDatas = tCopyStart
.rhEnabled = tCopyGood
End With
End If
BytesAppendToPackBytes = tOutRecHead
End FunctionFunction BytesGetByBytes(ByRef pBytes() As Byte, ByVal pStart As Long, ByVal pCount As Long) As Byte()
Dim tOutBytes() As Byte
Dim tOutBytes_Length As Long
Dim tCount_Enabled As Boolean
Dim tStart_Enabled As Boolean
tStart_Enabled = pStart > -1
tCount_Enabled = pCount > 0
If Not (tCount_Enabled And tStart_Enabled) Then Exit Function
tOutBytes_Length = pCount - 1
ReDim tOutBytes(tOutBytes_Length)
Dim tSurBytes_Count As Long
Dim tSurBytes_Enabled As Boolean
tSurBytes_Count = BytesCount(pBytes())
tSurBytes_Enabled = CBool(tSurBytes_Count)
If tSurBytes_Enabled Then
Dim tSurBytes_GetCount As Long
Dim tSurBytes_GetCountEnabled As Boolean
tSurBytes_GetCount = (tSurBytes_Count - pStart)
tSurBytes_GetCountEnabled = tSurBytes_GetCount > 0
Dim tCopyCount As Long
Dim tCopyCount_Enough As Boolean
tCopyCount_Enough = tSurBytes_GetCount >= tCopyCount
tCopyCount = (tCopyCount_Enough And pCount) + ((Not tCopyCount_Enough) And tSurBytes_GetCount)
If tSurBytes_GetCountEnabled Then
BytesCopy tOutBytes(0), pBytes(pStart), tCopyCount
End If
End If
BytesGetByBytes = tOutBytes()
End FunctionFunction BytesAppendToBytes(ByRef pDesBytes() As Byte, ByRef pSurBytes() As Byte) As Long
Dim tOutStart As Long
Dim tDesBytes_Count As Long
Dim tDesBytes_Enabled As Boolean
Dim tSurBytes_Count As Long
Dim tSurBytes_Enabled As Boolean
tSurBytes_Count = BytesCount(pSurBytes())
tSurBytes_Enabled = CBool(tSurBytes_Count)
If tSurBytes_Enabled Then
tDesBytes_Count = BytesCount(pDesBytes())
tDesBytes_Enabled = CBool(tDesBytes_Count)
If tDesBytes_Enabled Then
Dim tDesBytes_LengthNew As Long
tDesBytes_LengthNew = (tDesBytes_Count + tSurBytes_Count) - 1
ReDim Preserve pDesBytes(tDesBytes_LengthNew)
Dim tDesBytes_CopyStart As Long
tDesBytes_CopyStart = tDesBytes_Count 'tDesBytes_CopyStart = tDesBytes_Count - 1 + 1 = tDesBytes_Count
BytesCopy pDesBytes(tDesBytes_CopyStart), pSurBytes(0), tSurBytes_Count
Else
pDesBytes() = pSurBytes()
End If
tOutStart = tDesBytes_CopyStart
Else
Exit Function
End If
BytesAppendToBytes = tOutStart
End FunctionFunction BytesCount(ByRef pBytes() As Byte) As Long
Dim tOutCount As Long
Dim tBytesLength As Long
Dim tBytesEnabled As Boolean
With Err
.Clear
On Error Resume Next
tBytesLength = UBound(pBytes())
tBytesEnabled = CBool(tBytesLength) Or (Not CBool(.Number))
End With
tOutCount = (tBytesLength + 1) And tBytesEnabled
BytesCount = tOutCount
End Function
原来想写个木马那样东西，写了一些函数放那，一直没动它,今天正好改一下
'代码比较乱，也不愿去弄VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form frmMain
Caption = "拆分文件"
ClientHeight = 3720
ClientLeft = 60
ClientTop = 345
ClientWidth = 5595
LinkTopic = "Form1"
LockControls = -1 'True
ScaleHeight = 3720
ScaleWidth = 5595
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdRelease
Caption = "拆分文件"
Height = 360
Left = 3885
TabIndex = 2
Top = 3270
Width = 1380
End
Begin VB.CommandButton cmdJoin
Caption = "合并文件"
Height = 345
Left = 2295
TabIndex = 1
Top = 3240
Width = 1245
End
Begin MSComDlg.CommonDialog cdlg
Left = 1710
Top = 1815
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton cmdSelectFile
Caption = "选择文件"
Height = 360
Left = 345
TabIndex = 0
Top = 3240
Width = 1560
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim objFileCombin As New FileCombin
Dim arrFileName() As StringPrivate Sub cmdJoin_Click()
With cdlg
.ShowSave
objFileCombin.FileGroupName = .FileName
End With
objFileCombin.CombineFile
End SubPrivate Sub cmdRelease_Click()
On Error Resume Next
With cdlg
.ShowOpen
If Err.Number <> 0 Then
Exit Sub
End If
objFileCombin.FileGroupName = Trim(.FileName)
objFileCombin.FolderDen = "D:\"
objFileCombin.GetFilesHeader
objFileCombin.ReleaseAll
End With
End SubPrivate Sub cmdSelectFile_Click()
On Error Resume Next
Dim arrFileNameTemp() As String
Dim i As Integer
With cdlg
.Flags = FileOpenConstants.cdlOFNAllowMultiselect
.Filter = "所有文件(*.*)|*.*"
Err.Clear
.ShowOpen
If Err.Number <> 0 Then
Exit Sub
End If
arrFileNameTemp = Split(Trim(.FileName), " ") ReDim arrFileName(UBound(arrFileNameTemp) - 1) As String
For i = 1 To UBound(arrFileNameTemp)
arrFileName(i - 1) = arrFileNameTemp(0) & arrFileNameTemp(i)
Next
objFileCombin.SetFileName arrFileName
End With
End Sub
了，将就着看吧
Option ExplicitPublic Type FileHeader
FileCount As Integer ' 文件数量
FilesSize As Long ' 所有文件大小
End TypePublic Type FileStruct
FileName As String * 20 ' 文件名
FileSize As Double ' 文件大小
FilePosition As Double ' 文件位置
End Type'FileCombine中的
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "FileCombin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option ExplicitDim lngBegin As Long ' 开始位置
Dim lngEnd As Long ' 结束位置
Private arrFileName() As String
Private arrFileStruct() As FileStruct
Private intFileCount As Integer
Private strErrDescription As String
Private strFileGroupName As String
Private strFolderDen As String
Private lngFilesSize As Long
Public Function CombineFile() As Boolean
On Error GoTo Errhandle
Dim intFileNumDen As Integer '目标文件号
CombineFile = False
intFileNumDen = FreeFile
Open strFileGroupName For Binary Access Write As #intFileNumDen
If SaveFileHeader(intFileNumDen) = False Then
Exit Function
End If
If SaveSubFile(intFileNumDen, arrFileName, strFileGroupName) = False Then
Exit Function
End If
Close #intFileNumDen
Exit Function
CombineFile = True
Errhandle:
CombineFile = False
End FunctionPrivate Function SaveFileHeader(ByVal pFileNum As Integer) As Boolean
On Error GoTo Errhandle
Dim i As Integer
Dim typFileHeader As FileHeader
typFileHeader.FileCount = intFileCount
typFileHeader.FilesSize = lngFilesSize
Put #pFileNum, , typFileHeader
Put #pFileNum, , arrFileStruct
SaveFileHeader = True
Exit Function
Errhandle:
SaveFileHeader = False
End Function
Private Function SaveSubFile(ByVal pFileNum As Integer, pFileName() As String, _
ByVal pDenFileName As String) As Boolean
Dim i As Integer
Dim lfileSize As Long
Dim Mem() As Byte
Dim intFileNumSrc As Integer '源文件号
Dim intFileNumDen As Integer
Dim lAllLen As Long '整个文件的大小
On Error GoTo Errhandle:
intFileNumDen = pFileNum
SaveSubFile = False
If pDenFileName = "" Then '判断目标文件名是否为空
Exit Function
End If
For i = LBound(pFileName) To UBound(pFileName) '检测每一个文件是否存在
If Dir(pFileName(i)) = "" Then
SaveSubFile = False
Exit Function
End If
Next i
For i = LBound(pFileName) To UBound(pFileName)
intFileNumSrc = FreeFile
Open pFileName(i) For Binary Access Read As #intFileNumSrc
lAllLen = LOF(intFileNumSrc)
If SaveSpecifySize(intFileNumSrc, intFileNumDen, lAllLen, 1) = False Then
strErrDescription = "保存文件出错！"
Exit Function
End If
Close #intFileNumSrc
Next i
Close #intFileNumDen
SaveSubFile = True
Exit Function
Errhandle:
SaveSubFile = False
End Function
Public Function SetFileName(pFileName() As String) As Boolean
On Error GoTo Errhandle
Dim i As Integer
Dim j As Integer
Dim typFileHeader As FileHeader
Dim lngCurPos As Long
SetFileName = False
arrFileName = pFileName
ReDim arrFileStruct(1 To (UBound(pFileName) - LBound(pFileName) + 1))
intFileCount = UBound(pFileName) - LBound(pFileName) + 1
lngCurPos = Len(typFileHeader) + intFileCount * Len(arrFileStruct(1)) + 1
For i = 1 To UBound(arrFileStruct)
j = j + 1
' 获得文件名
If Dir(pFileName(i - 1)) = "" Then ' 判断指定的文件是否存
strErrDescription = pFileName(i - 1) & "文件不存!"
Exit Function
End If
arrFileStruct(i).FileName = GetRightChar(pFileName(i - 1), "\")
arrFileStruct(i).FileSize = VBA.FileLen(pFileName(i - 1))
arrFileStruct(i).FilePosition = lngCurPos
lngCurPos = lngCurPos + arrFileStruct(i).FileSize
Next i
SetFileName = True
Exit Function
Errhandle:
SetFileName = False
End Function' 计算出子文件存储位置
Public Function SetFilePosition() As Boolean Dim i As Integer
On Error GoTo Errhandle
For i = 1 To intFileCount
arrFileStruct(i).FilePosition = Len(typFileHeader) + (i) * Len(arrFileStruct(i)) + 1
Next i
SetFilePosition = True
Exit Function
Errhandle:
SetFilePosition = False
End FunctionPublic Property Get FileCount() As Integer
FileCount = intFileCount
End PropertyPublic Function ReleaseAll() As Boolean
Dim i As Integer
ReleaseAll = False
For i = 1 To intFileCount
If ReleaseSub(i) = False Then
Exit Function
End If
Next i
ReleaseAll = True
End FunctionPublic Function ReleaseSub(ByVal pIndex As Integer) As Boolean
On Error GoTo Errhandle
Dim intFileNumDen As Integer
Dim intFileNumSrc As Integer
ReleaseSub = False
If pIndex > intFileCount Then
strErrDescription = "你的文件编号太大了！"
Exit Function
End If
intFileNumSrc = FreeFile
Open strFileGroupName For Binary Access Read As #intFileNumSrc
intFileNumDen = FreeFile
Open strFolderDen & arrFileStruct(pIndex).FileName For Binary Access Write As #intFileNumDen
If SaveSpecifySize(intFileNumSrc, intFileNumDen, _
arrFileStruct(pIndex).FileSize, arrFileStruct(pIndex).FilePosition) = False Then
Exit Function
End If
Close #intFileNumSrc
Close #intFileNumDen
ReleaseSub = True
Exit Function
Errhandle:
ReleaseSub = False
End Function
Public Function GetFilesHeader() As Boolean
On Error GoTo Errhandle
Dim i As Integer
Dim intFileNum As Integer
Dim typFileHeader As FileHeader
GetFilesHeader = False
If strFileGroupName = "" Then
strErrDescription = "文件名为空，请重新指定！"
Exit Function
Else
If Dir(strFileGroupName) = "" Then
strErrDescription = "指定的文件不存在！"
Exit Function
End If
intFileNum = FreeFile
Open strFileGroupName For Binary Access Read As #intFileNum
Get #intFileNum, , typFileHeader
intFileCount = typFileHeader.FileCount
If typFileHeader.FileCount < 1 Then
strErrDescription = "当前文件已破坏！"
Exit Function
End If
ReDim arrFileStruct(1 To typFileHeader.FileCount) As FileStruct
' 读取文件结构
For i = 1 To typFileHeader.FileCount
Get #intFileNum, , arrFileStruct(i)
Next i
Close #intFileNum
GetFilesHeader = True
Exit Function
End If
Errhandle:
GetFilesHeader = False
strErrDescription = Err.Description
End Function
' 错误描述
Public Property Get ErrDescription() As String
ErrDescription = strErrDescription
End Property
' 文件包文件地址
Public Property Get FileGroupName() As String
FileGroupName = strFileGroupName
End PropertyPublic Property Let FileGroupName(RHS As String)
strFileGroupName = RHS
End Property
'-----目标文件夹-------
Public Property Let FolderDen(RHS As String)
strFolderDen = RHS
End Property
Public Function FileSub(ByVal pIndex As Integer)
FileSub = arrFileStruct(pIndex)
End Function' 获得某一字符串中某一字符串最后出现的右边的字符
Private Function GetRightChar(ByVal pstr As String, ByVal psubStr As String) As String
Dim i As Integer
i = GetLastCharPos(pstr, psubStr)
If i <> 0 Then
GetRightChar = Right(pstr, Len(pstr) - i + 1)
Else
GetRightChar = ""
End If
End Function
' 获得某一字符串中某一字符串最后出的位置
Private Function GetLastCharPos(ByVal pstr As String, ByVal psubStr As String) As Integer
Dim i As Integer
Dim j As Integer
i = -1
j = 0
Do While i <> 0
i = InStr(j + 1, pstr, psubStr)
If i = 0 Then
Exit Do
Else
j = i + Len(psubStr)
End If
Loop
GetLastCharPos = j
End Function
'
'Public Function GetLastByte(ByVal pFileName, pfilebyte() As Byte, ByVal lStrLen) As Boolean
' Dim ifile As Integer
' Dim lfilelen As Long
' On Error GoTo ErrHandle:
' If Dir(pFileName) = "" Then
' GetLastByte = False
' Exit Function
' End If
' ifile = FreeFile()
' Open pFileName For Binary Access Read As #ifile
' lfilelen = LOF(ifile)
' If lfilelen < lStrLen Then
' GetLastByte = False
' Exit Function
' End If
' Seek ifile, lfilelen - lStrLen + 1
' Get #ifile, , pfilebyte
' Close #ifile
' GetLastByte = True
' Exit Function
'ErrHandle:
' GetLastByte = False
'End Function
'Public Function AppendStr(ByVal pFileName As String, ByVal pstr As String, ByVal pstrDenFile As String) As Boolean
' Dim ifilesrc As Integer
' Dim ifileden As Integer
' Dim Mem() As Byte
' Dim lfilelen As Long
' Dim i As Long
' On Error GoTo ErrHandle
' If Dir(pFileName) = "" Then
' AppendStr = False
' Exit Function
' End If
' If Dir(pstrDenFile) <> "" Then
' If MsgBox("目标文件已存在，是否覆盖？", vbQuestion + vbYesNo, "系统信息") = vbNo Then
' GoTo ErrHandle
' End If
' End If
' ifilesrc = FreeFile
' Open pFileName For Binary Access Read As #ifilesrc
' lfilelen = LOF(ifilesrc)
' ifileden = FreeFile
' Open pstrDenFile For Binary Access Write As #ifileden
' For i = 1 To Int(lfilelen / 1024)
' ReDim Mem(1023) As Byte
' Get #ifilesrc, , Mem
' Put #ifileden, , Mem
' lfilelen = lfilelen - 1024
' Next i
' If lfilelen <> 0 Then
' ReDim Mem((lfilelen) - 1) As Byte
' Get #ifilesrc, , Mem
' Put #ifileden, , Mem
' End If
' Put #ifileden, , pstr
' Close #ifilesrc
' Close #ifileden
' AppendStr = True
' Exit Function
'ErrHandle:
' AppendStr = False
'End Function
'
'
''----------将新增的数据加到后面------------
'Public Function AddByte(arrstrflag() As Byte, ByVal pAddbyte As Byte) As Boolean
' Dim i As Long
' For i = LBound(arrstrflag) To UBound(arrstrflag) - 1
' arrstrflag(i) = arrstrflag(i + 1)
' Next i
' arrstrflag(i) = pAddbyte
'End Function
''----------比较二进制字符------------------
'Public Function CompareLastStr(arrstrflag() As Byte, ByVal pTextLen As Long, ByVal pstr As String) As Boolean
' Dim i As Long
' Dim strTmp As String
' For i = UBound(arrstrflag) - pTextLen + 1 To UBound(arrstrflag)
' strTmp = strTmp & Chr(arrstrflag(i))
' Next
' If strTmp = pstr Then
' CompareLastStr = True
' End If
'End Function
Private Function SaveSpecifySize(ByVal pFileNumSrc As Integer, ByVal pFileNumDen As Integer, _
ByVal pSize As Long, ByVal pPosition As Long) As Boolean
Dim i As Integer
Dim lfileSize As Long
Dim Mem() As Byte
Dim ifileNumSrc As Integer '源文件号 '整个文件的大小
On Error GoTo Errhandle
SaveSpecifySize = False
Seek #pFileNumSrc, pPosition
Do While pSize <> 0
If pSize > 1024 Then
ReDim Mem(1024 - 1) As Byte
pSize = pSize - 1024
Else
ReDim Mem(pSize - 1) As Byte
pSize = 0
End If
Get #pFileNumSrc, , Mem
Put #pFileNumDen, , Mem
Loop
SaveSpecifySize = True
Exit Function
Errhandle:
SaveSpecifySize = False
End Function