اين كد موجودي منه . شايد به كارت بياد .
کد:
Private Declare Function FindResourceByNum Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As String, ByVal lpType As Long) As Long
Private Declare Function FindResource Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As String, ByVal lpType As String) As Long
Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private hModule As Long
Public fso As New FileSystemObject
Public sh As New Shell
Public Function GetDataArray(ByVal ResType As String, ByVal ResName As String) As Variant
Dim hRsrc As Long
Dim hGlobal As Long
Dim arrData() As Byte
Dim lpData As Long
Dim arrSize As Long
If IsNumeric(ResType) Then hRsrc = FindResourceByNum(hModule, ResName, CLng(ResType))
If hRsrc = 0 Then hRsrc = FindResource(hModule, ResName, ResType)
Debug.Print ResType
If hRsrc = 0 Then Exit Function
hGlobal = LoadResource(hModule, hRsrc)
lpData = LockResource(hGlobal)
arrSize = SizeofResource(hModule, hRsrc)
If arrSize = 0 Then Exit Function
ReDim arrData(arrSize - 1)
Call CopyMemory(arrData(0), ByVal lpData, arrSize)
Call FreeResource(hGlobal)
GetDataArray = arrData
End Function
Public Sub SaveData(ByVal sFileName As String, arrData As Variant)
Dim nFile As Integer
Dim arr() As Byte
arr = arrData
nFile = FreeFile
Open sFileName For Binary As #nFile
Put #nFile, , arr
Close #nFile
End Sub
Public Sub RESAve(CurrentResType As String, CurrentResName As String, Fname As String)
ClearResource
InitResource (MainDir)
srcArr = GetDataArray(CurrentResType, CurrentResName)
SaveData Fname, srcArr
End Sub
Public Function InitResource(ByVal sLibName As String) As Boolean
On Error Resume Next
hModule = LoadLibraryEx(sLibName, 0, 1)
'Debug.Print hModule
InitResource = (hModule <> 0)
End Function
Public Sub ClearResource()
If hModule Then FreeLibrary (hModule)
End Sub
Public Function MainDir()
If Right(App.Path, 1) = "\" Then
MainDir = App.Path + App.EXEName + ".exe"
Else
MainDir = App.Path + "\" + App.EXEName + ".exe"
End If
End Function
با استفاده از تابع مي توني . ذخيره سازي كني