Arhive$ = RegGetValue(HKEY_CLASSES_ROOT, ".rar\ShellNew", "FileName"
Arhive$ = Left(Arhive$, Len(Arhive$) - Len(Spliting(Arhive$, "\")) 'берём его путь

[CODE]Public Function RegGetValue(hKey As RootKey, strSubKey As String, strValueName As String) As String
    Dim lngDataLen As Long, hSubKey As Long, strSetting As String
    If RegOpenKeyEx(hKey, strSubKey, 0, KEY_ALL_ACCESS, hSubKey) = ERROR_SUCCESS Then
        strSetting = Space(255): lngDataLen = Len(strSetting)
        If RegQueryValueEx(hSubKey, strValueName, ByVal 0, REG_SZ, ByVal strSetting, lngDataLen) = ERROR_SUCCESS Then
            If lngDataLen > 1 Then RegGetValue = Left(strSetting, lngDataLen - 1)
        End If
        RegCloseKey hSubKey
    End If
End Function

Public Function Spliting(sFullPath As String, point As String)
If sFullPath = "" Then Exit Function
Dim str1() As String
str1 = Split(sFullPath, point)
Spliting = str1(UBound(str1))
End Function

Option Explicit
Public Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwReserved As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegCreateKey Lib "ADVAPI32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegCloseKey& Lib "advapi32" (ByVal hKey As Long)
Public Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegQueryInfoKey Lib "ADVAPI32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As Any) As Long
Public Declare Function RegSetValueEx Lib "ADVAPI32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Declare Function RegEnumKeyEx Lib "ADVAPI32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Public Declare Function RegEnumValue Lib "ADVAPI32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegDeleteKey Lib "ADVAPI32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Public Declare Function RegDeleteValue Lib "ADVAPI32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

Private Const KEY_ALL_ACCESS            As Long = ((&H1F0000 Or &H1 Or &H2 Or &H4 Or &H8 Or &H10 Or &H20) And (Not &H100000))
Private Const REG_SZ                    As Long = &H1
Private Const REG_DWORD                 As Long = &H4
Private Const ERROR_SUCCESS             As Long = &H0

Public Enum RootKey
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
End Enum

Public Function RegGetValue(hKey As RootKey, strSubKey As String, strValueName As String) As String
    Dim lngDataLen As Long, hSubKey As Long, strSetting As String
    If RegOpenKeyEx(hKey, strSubKey, 0, KEY_ALL_ACCESS, hSubKey) = ERROR_SUCCESS Then
        strSetting = Space(255): lngDataLen = Len(strSetting)
        If RegQueryValueEx(hSubKey, strValueName, ByVal 0, REG_SZ, ByVal strSetting, lngDataLen) = ERROR_SUCCESS Then
            If lngDataLen > 1 Then RegGetValue = Left(strSetting, lngDataLen - 1)
        End If
        RegCloseKey hSubKey
    End If
End Function

Public Sub RegSetValue(hKey As RootKey, strSubKey As String, strKey As String, strValue As String)
    Dim keyhand As Long
    Call Trim(strKey): Call Trim(strValue)   'Убираем пробелы в нач. и кон. строки
    If Len(strKey) = 0 Or Len(strValue) = 0 Then Exit Sub

    Call RegCreateKey(hKey, strSubKey, keyhand)
    Call RegSetValueEx(keyhand, strKey, 0, 1&, ByVal strValue, Len(strValue) + 1)
    Call RegCloseKey(keyhand)
End Sub

Public Sub RegSetKey(hKey As RootKey, strSubKey As String)
    Dim keyhand As Long
    RegCreateKey hKey, strSubKey, keyhand
    RegCloseKey keyhand
End Sub

Public Function RegGetDWord(hKey As RootKey, strSubKey As String, strValueName As String) As Long
    Dim hSubKey As Long, lngRetVal As Long
    If RegOpenKeyEx(hKey, strSubKey, 0, KEY_ALL_ACCESS, hSubKey) = ERROR_SUCCESS Then
        If RegQueryValueEx(hSubKey, strValueName, ByVal 0, REG_DWORD, lngRetVal, 4) = ERROR_SUCCESS Then RegGetDWord = lngRetVal
        RegCloseKey hSubKey
    End If
End Function

Public Sub RegSetDWord(hKey As RootKey, strSubKey As String, strValueName As String, lngData As Long)
    Dim hNewHandle As Long
    RegCreateKey hKey, strSubKey, hNewHandle
    RegSetValueEx hNewHandle, strValueName, 0, REG_DWORD, lngData, 4
    RegCloseKey hNewHandle
End Sub

Public Function RegGetKeys(hKey As RootKey, strSubKey As String, strRetArray() As String, Optional Range As Long) As Long
    Dim hChildKey As Long, lngSubKeys As Long, lngMaxKeySize As Long, lngDataRetBytes As Long, i As Integer
    If Len(strSubKey) Then
        If RegOpenKeyEx(hKey, strSubKey, 0, KEY_ALL_ACCESS, hChildKey) <> ERROR_SUCCESS Then Range = -1: Erase strRetArray: Exit Function
    Else
        hChildKey = hKey
    End If
    If QueryRegInfoKey(hChildKey, lngSubKeys, lngMaxKeySize) <> ERROR_SUCCESS Or lngSubKeys = 0 Then
        If Len(strSubKey) Then RegCloseKey hChildKey
        Range = -1
        Erase strRetArray
        Exit Function
    End If
    lngSubKeys = lngSubKeys - 1
    ReDim strRetArray(lngSubKeys) As String
    For i = 0 To lngSubKeys
        lngDataRetBytes = lngMaxKeySize
        strRetArray(i) = Space(lngMaxKeySize)
        RegEnumKeyEx hChildKey, i, strRetArray(i), lngDataRetBytes, 0&, vbNullString, ByVal 0&, ByVal 0&
        strRetArray(i) = Left(strRetArray(i), lngDataRetBytes)
    Next i
    If Len(strSubKey) Then RegCloseKey hChildKey
    Range = lngSubKeys
    RegGetKeys = lngSubKeys
End Function

Public Function RegGetKeyValues(hKey As RootKey, strSubKey As String, strValues() As String, Optional Range As Long) As Long
    Dim lngMaxValSize  As Long, lngValRetBytes As Long, lngMaxSettingSize As Long, lngSetRetBytes As Long
    Dim lngSetting As Long, lngType As Long, hChildKey As Long, i As Integer, lngNumValues As Long

    If RegOpenKeyEx(hKey, strSubKey, 0, KEY_ALL_ACCESS, hChildKey) <> ERROR_SUCCESS Then Range = -1: Erase strValues: Exit Function
    If QueryRegInfoKey(hChildKey, , , lngNumValues, lngMaxValSize, lngMaxSettingSize) <> ERROR_SUCCESS Or lngNumValues = 0 Then RegCloseKey hChildKey: Erase strValues: Exit Function

    lngNumValues = lngNumValues - 1
    ReDim strValues(0 To lngNumValues, 0 To 1) As String
    For i = 0 To lngNumValues
        strValues(i, 0) = Space(lngMaxValSize): lngValRetBytes = lngMaxValSize: strValues(i, 1) = Space(lngMaxSettingSize)
        lngSetRetBytes = lngMaxSettingSize

        RegEnumValue hChildKey, i, strValues(i, 0), lngValRetBytes, 0, lngType, ByVal strValues(i, 1), lngSetRetBytes
        If lngType = REG_SZ Then
            strValues(i, 1) = Left(strValues(i, 1), lngSetRetBytes - 1)
        ElseIf lngType = REG_DWORD Then
            lngValRetBytes = lngValRetBytes + 1
            RegEnumValue hChildKey, i, strValues(i, 0), _
                lngValRetBytes, 0, lngType, lngSetting, lngSetRetBytes
            strValues(i, 1) = CStr(lngSetting)
        Else
            strValues(i, 1) = vbNullString
        End If
        strValues(i, 0) = RTrim(Left(strValues(i, 0), lngValRetBytes))
        strValues(i, 1) = RTrim(strValues(i, 1))
    Next i
    RegCloseKey hChildKey
    Range = lngNumValues
    RegGetKeyValues = lngNumValues
End Function

Private Function QueryRegInfoKey(hKey As RootKey, Optional lngSubKeys As Long, Optional lngMaxKeyLen As Long, Optional lngValues As Long, Optional lngMaxValNameLen As Long, Optional lngMaxValLen As Long)
    QueryRegInfoKey = RegQueryInfoKey(hKey, vbNullString, ByVal 0&, 0&, lngSubKeys, lngMaxKeyLen, ByVal 0&, lngValues, lngMaxValNameLen, lngMaxValLen, ByVal 0&, ByVal 0&
    lngMaxKeyLen = lngMaxKeyLen + 1
    lngMaxValNameLen = lngMaxValNameLen + 1
    lngMaxValLen = lngMaxValLen + 1
End Function



Public Sub RegDelKey(hKey As RootKey, strKeyToDel As String)
    RegDeleteKey hKey, strKeyToDel
End Sub

Public Sub RegDelValue(hKey As RootKey, strSubKey As String, strValToDel As String)
    Dim hSubKey As Long
    RegOpenKeyEx hKey, strSubKey, 0, KEY_ALL_ACCESS, hSubKey
    RegDeleteValue hSubKey, strValToDel
    RegCloseKey hSubKey
End Sub

'Копирование стринговых значений из 1-го ключа в другой
'Public Sub CopyKeyVal(hKey As RootKey, sFrom As String, sTo As String)
'    im sArray() As String, ii As Long
'    Call RegGetKeyValues(HKEY_LOCAL_MACHINE, sFrom, sArray)
'    For ii = 0 To UBoundS(sArray)
'        Call RegSetValue(HKEY_LOCAL_MACHINE, sTo, sArray(ii, 0), sArray(ii, 1))
'    Next
'End Sub

'===========================================================|
' <МОДУЛЬ ДЛЯ C RARom, КОТОРЫЙ УСТАНОВЛЕН В СИСТЕМЕ.       >|
'                                                           |
' = = = = = = = M A D E   B Y   H A C K E R = = = = = =     |
'         icq: 334479038, mail: visualbasic@xaker.ru        |
'===========================================================|

'Нужны функции работы с реестром (модуль reg.bas)
'Поддерживает только WinRar, степень сжатия - максимальная
'Возможность установить на архив пароль


Public Sub ArhiveToWinRar(file$, Password$, RarFile$)
'Находим в компе архиватор
Arhive$ = RegGetValue(HKEY_CLASSES_ROOT, ".rar\ShellNew", "FileName"
If Arhive$ <> "" Then ' Если есть на компе архиватор...
Arhive$ = Left(Arhive$, Len(Arhive$) - Len(Spliting(Arhive$, "\")) 'берём его путь
'Смотрим какой архиватор...
    If InStr(1, LCase(Arhive$), "winrar", vbTextCompare) > 0 Then 'Если WinRar
        'Формируем коммандную строку для архивации
        If RarFile$ = "" Then RarFile$ = Replace(file$, Spliting(file$, ".", "rar"
        Arhive$ = Chr(34) & Arhive$ & "Rar.exe" & Chr(34) & " a -m5 -inul -ep -ep1 -idp -p" & Password$ & " " & Chr(34) & RarFile$ & Chr(34) & " " & Chr(34) & file$ & Chr(34)
    End If
End If

Shell Arhive$, vbHide
End Sub

Public Sub ExtractWinRar(RarFile$, Password$, sDir$)
'Находим в компе архиватор
Arhive$ = RegGetValue(HKEY_CLASSES_ROOT, ".rar\ShellNew", "FileName"
If Arhive$ <> "" Then ' Если есть на компе архиватор...
Arhive$ = Left(Arhive$, Len(Arhive$) - Len(Spliting(Arhive$, "\")) 'берём его путь
'Смотрим какой архиватор...
    If InStr(1, LCase(Arhive$), "winrar", vbTextCompare) > 0 Then 'Если WinRar
        'Формируем коммандную строку для архивации
        If RarFile$ = "" Then RarFile$ = Replace(file$, Spliting(file$, ".", "rar"
        If Password$ = "" Then
            Arhive$ = Chr(34) & Arhive$ & "unrar.exe" & Chr(34) & " e -idb -o+ -y" & " " & Chr(34) & RarFile$ & Chr(34) & " " & Chr(34) & sDir$ & Chr(34)
        Else
            Arhive$ = Chr(34) & Arhive$ & "unrar.exe" & Chr(34) & " e -idb -o+ -y -p" & Password & " " & Chr(34) & RarFile$ & Chr(34) & " " & Chr(34) & sDir$ & Chr(34)
        End If
        
    End If
End If
Shell Arhive$, vbHide
End Sub