VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "ZipClass" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False 'aqui voce define o nome da dll ou dlls que serao utilizadas Private Const GlobalFile As String = "rspbzip2.rsp" 'aqui deve vim de um arquivo Private Const ZipRes = 1 Private Declare Function GetTickCount Lib "kernel32" () As Long Private RSPalreadyLoaded As Boolean 'Public Declare Function GetTickCount Lib "kernel32" () As Long Private Declare Function CreateDirectoryA Lib "kernel32.dll" (ByVal Path As String, ByVal Referencia As Long) As Long Private Declare Function GetTempPathA Lib "kernel32.dll" (ByVal bufferlenght As Long, ByVal buffer As String) As Long Private Declare Function GetModuleHandleA Lib "kernel32.dll" (ByVal modulename As String) As Long Private Declare Function GetWindowsDirectory% Lib "Kernel" (ByVal lpBuffer _ As String, ByVal nsize As Long) Private Declare Function GetSystemDirectory% Lib "Kernel" (ByVal lpBuffer _ As String, ByVal nsize As Long) Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private lb As Long, pa As Long Private GlobalName As String Private Declare Sub RSPCopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ ByVal hpvDest As Long, ByVal hpvSource As Long, ByVal cbCopy As Long) Private Declare Function OutputDebugStringA Lib _ "kernel32.dll" _ (ByVal Inputfile As String) As Long Public Function CallWindow2(string11 As String, string22 As String, string33 As String, ByVal string44 As Long) As Long 'a rotina de execucao de carregamento e chamada de valores esta feita 'agora tem que aprender a passar strings Dim ret As Long If lb = 0 Then MsgBox "error loading the dll" Exit Function End If If pa = 0 Then MsgBox "error locating the interface1 function " Exit Function End If string11 = string11 & Chr(0) string22 = string22 & Chr(0) string33 = string33 & Chr(0) Dim String1() As Byte Dim String2() As Byte Dim String3() As Byte string11 = StrConv(string11, vbFromUnicode) string22 = StrConv(string22, vbFromUnicode) string33 = StrConv(string33, vbFromUnicode) 'msgboX string11 String1 = string11 String2 = string22 String3 = string33 ret = CallWindowProc(pa, VarPtr(String1(0)), VarPtr(String2(0)), VarPtr(String3(0)), string44) 'msgboX ret '// nao pode descarregtar a dll antes do fim do processo 'ret = FreeLibrary(lb) string11 = String1 string11 = StrConv(string11, vbUnicode) If InStr(1, string11, Chr$(0)) Then string11 = Left$(string11, InStr(1, string11, Chr$(0)) - 1) End If string22 = String2 string22 = StrConv(string22, vbUnicode) If InStr(1, string22, Chr$(0)) Then string22 = Left$(string22, InStr(1, string22, Chr$(0)) - 1) End If string33 = String3 string33 = StrConv(string33, vbUnicode) If InStr(1, string33, Chr$(0)) Then string33 = Left$(string33, InStr(1, string33, Chr$(0)) - 1) End If 'aqui ja deve ter retornado o valor correto CallWindow2 = ret End Function Public Function CallWindowLONG(string11 As String, string22 As Long, string33 As Long, ByVal string44 As Long) As Long 'a rotina de execucao de carregamento e chamada de valores esta feita 'agora tem que aprender a passar strings Dim ret As Long If lb = 0 Then MsgBox "error loading the dll" Exit Function End If If pa = 0 Then MsgBox "error locating the interface1 function " Exit Function End If string11 = string11 & Chr(0) '//string22 = string22 & Chr(0) 'string33 = string33 & Chr(0) Dim String1() As Byte 'Dim String2() As Byte 'Dim String3() As Byte string11 = StrConv(string11, vbFromUnicode) 'string22 = StrConv(string22, vbFromUnicode) 'string33 = StrConv(string33, vbFromUnicode) 'msgboX string11 String1 = string11 'String2 = string22 'String3 = string33 ret = CallWindowProc(pa, VarPtr(String1(0)), string22, string33, string44) 'msgboX ret '// nao pode descarregtar a dll antes do fim do processo 'ret = FreeLibrary(lb) 'string33 = String3 'string33 = StrConv(string33, vbUnicode) 'aqui ja deve ter retornado o valor correto CallWindowLONG = ret End Function Public Function CallWindow(string11 As String, string22 As String, string33 As String, string44 As String) As Long 'a rotina de execucao de carregamento e chamada de valores esta feita 'agora tem que aprender a passar strings Dim ret As Long If lb = 0 Then MsgBox "error loading the dll" Exit Function End If If pa = 0 Then MsgBox "error locating the interface1 function " Exit Function End If string11 = string11 & Chr(0) string22 = string22 & Chr(0) string33 = string33 & Chr(0) string44 = string44 & Chr(0) Dim String1() As Byte Dim String2() As Byte Dim String3() As Byte Dim String4() As Byte string11 = StrConv(string11, vbFromUnicode) string22 = StrConv(string22, vbFromUnicode) string33 = StrConv(string33, vbFromUnicode) string44 = StrConv(string44, vbFromUnicode) 'msgboX string11 String1 = string11 String2 = string22 String3 = string33 String4 = string44 ret = CallWindowProc(pa, VarPtr(String1(0)), VarPtr(String2(0)), VarPtr(String3(0)), VarPtr(String4(0))) 'msgboX ret '// nao pode descarregtar a dll antes do fim do processo 'ret = FreeLibrary(lb) CallWindow = ret End Function Public Function CallWindowInt(string11 As String, string22 As Long, string33 As Long, string44 As Long) As Long 'a rotina de execucao de carregamento e chamada de valores esta feita 'agora tem que aprender a passar strings Dim ret As Long If lb = 0 Then MsgBox "error loading the dll" Exit Function End If If pa = 0 Then MsgBox "error locating the interface1 function " Exit Function End If string11 = string11 & Chr(0) Dim String1() As Byte string11 = StrConv(string11, vbFromUnicode) 'msgboX string11 String1 = string11 ret = CallWindowProc(pa, VarPtr(String1(0)), string22, string22, string22) 'msgboX ret '// nao pode descarregtar a dll antes do fim do processo 'ret = FreeLibrary(lb) CallWindowInt = ret End Function Public Function Deinit() If RSPalreadyLoaded = False Then Exit Function If lb <> 0 Then ret = FreeLibrary(lb) 'msgboX "Descarregando a dll " End If 'agora nao precisa mais refazer o systema , com certeza Exit Function MsgBox "forcando a deletacao " & GetTempPathString & "RSPSoftware\" & GlobalFile On Error Resume Next If (GlobalName <> "") Then Kill GetTempPathString & "RSPSoftware\" & GlobalFile 'Kill GetTempPathString & "RSPSoftware\libbz2.dll" End If End Function Public Function Init(Optional fOrceinit As Boolean) 'basta definir a nova versao e pronto 'nao da para adicionar aqui este codigo If fOrceinit Then GoTo agora If RSPalreadyLoaded = True Then Exit Function 'msgboX "Carregando a dll " agora: On Error GoTo Error1 Dim Mystring As String Dim ret As Long Mystring = GetTempPathString & "RSPSoftware\" & GlobalFile GlobalName = Mystring If Dir(Mystring, vbArchive) = "" Then 'create the file and folder ret = CreateNewDirectory(GetTempPathString & "RSPSoftware\") If ret = False Then 'msgboX "Unable to create the folder " & GetTempPathString & "RSPSoftware\" Err.Raise 70, , "Unable to create the destination folder " & GetTempPathString & "RSPSoftware\" Exit Function End If ' criar os arquivos '1 RCDATA "rspbzp1.dll" '2 RCDATA "libbz2.dll" ExtractRes GlobalName, ZipRes Else 'aqui é que deve checar o Adler32 do arquivo Dim Original As Long Dim Arquivo As Long Original = ExtractResAdler32(ZipRes) Arquivo = Adler32file(GlobalName) If Original = Arquivo Then 'MsgBox "e igual , nao precisa refazer" Else 'MsgBox " _________dll refeita________ " RSPKill GlobalName ExtractRes GlobalName, ZipRes End If End If lb = LoadLibrary(GlobalName) If lb = 0 Then MsgBox "error loading the dll" Exit Function End If 'somente tem que ter esta api la dentro e fim de papo pa = GetProcAddress(lb, "interface1") If pa = 0 Then MsgBox "error locating the interface1 function " Exit Function Else ' msgboX "ok locating the export function" End If 'Dim Mystring2 As String 'Mystring2 = GetTempPathString & "RSPSoftware\libbz2.dll" & Chr(0) ''aqui carrega a dll 'ret = CallWindow("selectlibrary", Mystring2, " ", " ") RSPalreadyLoaded = True Exit Function Error1: On Error GoTo 0 Err.Raise 5001, , "Unexpected error , please contact the developer info@rspsoftware.clic3.net" End Function 'veja se desenvolve as coisas bem e manda brasa 've se ainda hoje manda alguma coisa para o site e comeca o desenvolvimento Function ExtractResAdler32(ByVal ResNumber As Long) As Long On Error GoTo Error1 Dim ret() As Byte ret = LoadResData(ResNumber, 10) Dim Ret2 As Long Ret2 = Adler32(ret) ExtractResAdler32 = Ret2 Exit Function Error1: Err.Clear Exit Function End Function Public Function Adler32file(ByVal Inputfile As String) As Long Dim ret As Long Dim Fatia() As Byte ReDim Fatia(0 To FileLen(Inputfile) - 1) Open Inputfile For Binary Access Read As #1 Get #1, , Fatia Close #1 Adler32file = Adler32(Fatia()) 'msgboX ret End Function Function ExtractRes(ByVal OutFile As String, ByVal ResNumber As Long) On Error GoTo Error1 Dim ret() As Byte '1 RCDATA "rspbzp1.dll" '2 RCDATA "libbz2.dll" ret = LoadResData(ResNumber, 10) 'Dim Ret2 As Long 'ret(UBound(ret)) = 2 'Ret2 = Adler32(ret3) 'msgboX UBound(ret) 'msgboX UBound(ret) & " " & ret(UBound(ret) + 1) 'abra um arquivo para salvar em binario e ponha o array de bytes 'msgboX Adler32(ret) Open OutFile For Binary Access Write As #1 Put #1, , ret() Close #1 'Adler32file (OutFile) Exit Function Error1: Err.Clear Exit Function End Function Public Function GetTempPathString() As String Dim buf As String buf = Space(300) ret = GetTempPathA(255, buf) If ret <> 0 Then buf = Left(buf, ret) End If If (Right(buf, 1) <> "\") Then buf = buf & "\" End If 'coisas simples de fazer em VB se voce sabe como fazer GetTempPathString = buf End Function Public Function CreateNewDirectory(NewDirectory As String) As Boolean 'funcao que cria diretorios esta pronta Dim sDirTest As String 'Dim SecAttrib As SECURITY_ATTRIBUTES Dim bSuccess As Boolean Dim Spath As String Dim iCounter As Integer Dim sTempDir As String 'Dim Spath As String iFlag = 0 Spath = NewDirectory If Right(Spath, Len(Spath)) <> "\" Then Spath = Spath & "\" End If iCounter = 1 Do Until InStr(iCounter, Spath, "\") = 0 iCounter = InStr(iCounter, Spath, "\") sTempDir = Left(Spath, iCounter) sDirTest = Dir(sTempDir) iCounter = iCounter + 1 bSuccess = CreateDirectoryA(sTempDir, 0) Loop If Dir(NewDirectory, vbDirectory) = "" Then CreateNewDirectory = False Else CreateNewDirectory = True End If End Function 'adicionar as funcoes que faltam para saber se existem os erros Public Function CheckInputFile(Inputfile As String) As Boolean 'retorna true se existir , fealse se nao existir On Error GoTo Error1 Dim Size As Long Size = FileLen(Inputfile) Dim Mystring As String If Size > 255 Then Mystring = Space(255) Else Mystring = Space(Size) End If Open Inputfile For Binary Access Read As #1 Get #1, , Mystring Close #1 CheckInputFile = True Exit Function Error1: Err.Clear CheckInputFile = False End Function Public Function CheckOuPutFile(ByVal Inputfile As String) As Boolean 'retorna true se existir , fealse se nao existir On Error GoTo Error1 Dim Mystring As String Mystring = " " Open Inputfile For Binary Access Write As #1 Put #1, , Mystring Close #1 CheckOuPutFile = True Kill Inputfile Exit Function Error1: Err.Clear CheckOuPutFile = False End Function Public Function CheckForEquality(ByVal Inputfile, ByVal OutPutFile) As Boolean Inputfile = UCase(Inputfile) OutPutFile = UCase(OutPutFile) If Inputfile = OutPutFile Then CheckForEquality = True Else CheckForEquality = False End If End Function Public Function CheckForEmpty(Inputfile) As Boolean If Inputfile = "" Then CheckForEmpty = True Else CheckForEmpty = False End If End Function '// insercao de codigo de adler32 Public Function Adler32(gData() As Byte) As Long Dim s1 As Long 'si = lo Dim s2 As Long 's2 = high Dim I As Long Const baseh = 32761 Const basel = 65531 For I = 0 To UBound(gData) s1 = s1 + gData(I) s2 = s2 + s1 If s1 > basel Then s1 = s1 Mod basel End If If s2 > baseh Then s2 = s2 Mod baseh End If Next I Adler32 = SetHILOword(s1, s2) End Function 'estao feitas as funcoes para efetuar a definicao dos valores sem risco de problemas Public Function GetHiWord(ByVal dword As Long) As Long Dim ret As Long RSPCopyMemory VarPtr(ret), VarPtr(dword) + 2, 2 GetHiWord = ret End Function Public Function GetLoWord(ByVal dword As Long) As Long Dim ret As Long RSPCopyMemory VarPtr(ret), VarPtr(dword), 2 GetLoWord = ret End Function Public Function SetHILOword(Loword As Long, Hiword As Long) As Long Dim ret As Long RSPCopyMemory VarPtr(ret), VarPtr(Loword), 2 RSPCopyMemory VarPtr(ret) + 2, VarPtr(Hiword), 2 SetHILOword = ret End Function Public Function RSPKill(ByVal filename As String) On Error Resume Next Kill filename End Function Public Function DevmsgboX(ByVal String1 As String) Exit Function String1 = String1 & Chr(0) OutputDebugStringA String1 End Function Public Function IsLoaded() As Boolean If RSPalreadyLoaded Then IsLoaded = True Else IsLoaded = False End If End Function