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