Crear Registro de mi Programa en el sistema

tema enviado por YAL PUBLICIDAD - RGP en Visual Basic 6.0
tema iniciado el 28/02/2007
CREAR REGISTRO DE PROGRAMA  

En esta ocación les enseñare como crear un programa para registralo en el sistema. Solo les brindo una pequeña
forma de hacerlo y ya quedará en ustedes las modificaciones le que le puedan hacer, para lo cual necesitamos
dos fomularios, al primero lo llamaremos frmMain y le colocamos lo que deseamos en el
segundo formulario lo llamamos frmRegistro y este sera el objeto inicial le colocamos un TextBox y dos botones
command1 y command2, tambien agregamos un modulo con el nombre que desees y YA! manos a la obra:

En el formulario colocamos el siguiente codigo:

frmRegistro


Option Explicit

Const ConMaxIntentos = 100

Private Sub Form_Load()

    Dim hKey As Long
    Dim hkeyExistente As Long
    Dim StrClave As String
    Dim StrCadenaRegistro As String
    Dim LngNumIntentos As Long
    Dim LngMaxIntentos As Long
    
        
    ' Abrimos la clave del regiStro
    If RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\MiClave123", hkeyExistente) Then
        
        ' Comprobamos si está registrado
        StrClave = "DatosRegistro"
        If RegQueryStringValue(hkeyExistente, StrClave, StrCadenaRegistro) Then
            RegCloseKey hkeyExistente
            'Si el esta registrado Abrimos el programa principal que es totalmente original.
            frmMain.Show
	    Unload frmRegistro
            Exit Sub
        End If
        
        ' Si no está registrado, obtenemos el número máximo de intentos
        StrClave = "MaxIntentos"
        If RegQueryNumericValue(hkeyExistente, StrClave, LngMaxIntentos) Then
                    
            ' Comprobamos cuántos intentos van
            StrClave = "NumIntentos"
            If RegQueryNumericValue(hkeyExistente, StrClave, LngNumIntentos) Then
                                    
                ' Comprobamos si se ha llegado al número máximo de intentos
                If LngNumIntentos < LngMaxIntentos Then
                    ' Incrementamos el número de usos y lo guardamos en el registro
                    LngNumIntentos = LngNumIntentos + 1
                    RegSetNumericValue hkeyExistente, "NumIntentos", LngNumIntentos
                    
                    ' Actualizamos el formulario
                    MsgBox "El Registro ha sido utilizada " & LngNumIntentos & " veces (máximo " & LngMaxIntentos & ")"
                Else
                    MsgBox "El tiempo de evaluación del programa culmino, contactese con su proveedor de programa para solicitar _
 			la clave de registro.", vbInformation
			frmRegistro.Command2.Enabled = False
                End If
            End If
        End If
        RegCloseKey hkeyExistente
    Else
    
        ' Como no existe el registro , la creamos
        If RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\MiClave123", hKey) Then
             
             ' Número máximo de intentos
             RegSetNumericValue hKey, "MaxIntentos", ConMaxIntentos
             
             ' Número de intentos realizado
             RegSetNumericValue hKey, "NumIntentos", 1
                 
             RegCloseKey hKey
             
             ' Actualizamos el formulario
             MsgBox "El Registro ha sido utilizada 1 vez (máximo " & ConMaxIntentos & ")"
         End If
    End If
Command1.Caption = "&Aceptar" 'nombre de boton 
Command2.Caption = "Usar programa de Evaluación" 'Boton para abrir como evaluacion
Me.Caption = "Mi registro" 'Nombre del form
End Sub

Public Sub Command1_Click()
On Error GoTo ClaveErronea
    If Text1.Text = "MiClave123" Then 'coloca la clave respetando las mayusculas
    	Call RealizarRegistro
    Else 
	MsgBox "¡La Clave es incorrecta!", vbInformation
 	Text1.SetFocus
    End If
Exit Sub
ClaveErronea:
    
End Sub

----------------------------------------------------------------------------------

 
'MODULO CON LAS FUNCIONES DEL REGISTRO EN EL SISTEMA
Option Explicit

' API de manipulación del regiStro (32 bits)
Declare Function OSRegCloseKey Lib "advapi32" Alias "RegCloseKey" (ByVal hKey As Long) As Long
Declare Function OSRegCreateKey Lib "advapi32" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Declare Function OSRegDeleteKey Lib "advapi32" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpszSubKey As String) As Long
Declare Function OSRegOpenKey Lib "advapi32" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Declare Function OSRegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpszValueName As String, ByVal dwReserved As Long, lpdwType As Long, lpbData As Any, cbData As Long) As Long
Declare Function OSRegSetValueEx Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpszValueName As String, ByVal dwReserved As Long, ByVal fdwType As Long, lpbData As Any, ByVal cbData As Long) As Long

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003
Const ERROR_SUCCESS = 0&

Const REG_SZ = 1
Const REG_BINARY = 3
Const REG_DWORD = 4

' Crea (o abre si ya existe) una clave en el registro del sistema
Function RegCreateKey(ByVal hKey As Long, ByVal lpszKey As String, phkResult As Long) As Boolean
    On Error GoTo 0
    
    If OSRegCreateKey(hKey, lpszKey, phkResult) = ERROR_SUCCESS Then
        RegCreateKey = True
    Else
        RegCreateKey = False
    End If
End Function

' Asocia un valor con nombre (StrValueName = nombre) o sin nombre (StrValueName = "")
' con una clave del regiStro.
Function RegSetStringValue(ByVal hKey As Long, ByVal strValueName As String, ByVal StrData As String) As Boolean
    On Error GoTo 0
    
    If hKey = 0 Then Exit Function
    
    If OSRegSetValueEx(hKey, strValueName, 0&, REG_SZ, ByVal StrData, _
        Len(StrData) + 1) = ERROR_SUCCESS Then
        RegSetStringValue = True
    Else
        RegSetStringValue = False
    End If
End Function

' Asocia un valor con nombre (strValueName = nombre) o sin nombre (strValueName = "")
'   con una clave del registro.
Function RegSetNumericValue(ByVal hKey As Long, ByVal strValueName As String, ByVal lData As Long, Optional ByVal fLog) As Boolean
    On Error GoTo 0
    
    If OSRegSetValueEx(hKey, strValueName, 0&, REG_DWORD, lData, 4) = ERROR_SUCCESS Then
        RegSetNumericValue = True
    Else
        RegSetNumericValue = False
    End If
End Function

' Abre una clave existente en el registro del sistema.
Function RegOpenKey(ByVal hKey As Long, ByVal lpszSubKey As String, phkResult As Long) As Boolean
    On Error GoTo 0

    If OSRegOpenKey(hKey, lpszSubKey, phkResult) = ERROR_SUCCESS Then
        RegOpenKey = True
    Else
        RegOpenKey = False
    End If
End Function

' Elimina una clave existente del regiStro del sistema.
Function RegDeleteKey(ByVal hKey As Long, ByVal lpszSubKey As String) As Boolean
    On Error GoTo 0
    
    If OSRegDeleteKey(hKey, lpszSubKey) = ERROR_SUCCESS Then
        RegDeleteKey = True
    Else
        RegDeleteKey = False
    End If
End Function

' Cierra una clave abierta del registro
Function RegCloseKey(ByVal hKey As Long) As Boolean
    On Error GoTo 0
    
    If OSRegCloseKey(hKey) = ERROR_SUCCESS Then
        RegCloseKey = True
    Else
        RegCloseKey = False
    End If
End Function

' Recupera los datos de cadena para un valor con nombre
' (StrValueName = nombre) o sin nombre (StrValueName = "")
' dentro de una clave del regiStro. Si el valor con
' nombre existe, pero sus datos no son una cadena, esta
' función fallará.
Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String, StrData As String) As Boolean
    On Error GoTo 0
    
    Dim lValueType As Long
    Dim StrBuf As String
    Dim lDataBufSize As Long
    
    RegQueryStringValue = False
    ' Obtiene el tipo y longitud de los datos
    If OSRegQueryValueEx(hKey, strValueName, 0&, lValueType, ByVal 0&, lDataBufSize) = ERROR_SUCCESS Then
        If lValueType = REG_SZ Then
            StrBuf = String(lDataBufSize, " ")
            If OSRegQueryValueEx(hKey, strValueName, 0&, 0&, ByVal StrBuf, lDataBufSize) = ERROR_SUCCESS Then
                StrData = Left(StrBuf, lDataBufSize - 1)
                RegQueryStringValue = True
            End If
        End If
    End If
End Function

' Recupera los datos enteros para un valor con nombre
' (StrValueName = nombre) o sin nombre (StrValueName = "")
' dentro de una clave del regiStro. Si el valor con nombre
' existe, pero sus datos no son de tipo REG_DWORD, esta
' función fallará.
Function RegQueryNumericValue(ByVal hKey As Long, ByVal strValueName As String, lData As Long) As Boolean
    On Error GoTo 0
    
    Dim lValueType As Long
    Dim lBuf As Long
    Dim lDataBufSize As Long
    
    RegQueryNumericValue = False
    
    ' Obtiene el tipo y longitud de los datos
    lDataBufSize = 4
    If OSRegQueryValueEx(hKey, strValueName, 0&, lValueType, lBuf, lDataBufSize) = ERROR_SUCCESS Then
        If lValueType = REG_DWORD Then
            lData = lBuf
            RegQueryNumericValue = True
        End If
    End If
End Function
Public Sub RealizarRegistro()
    Dim hkeyExistente As Long
    Dim StrClave As String
    Dim StrCadenaRegistro As String
    
    ' Registramos la aplicación (podríamos comprobar si es auténtico)
    If RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\MiClave123", hkeyExistente) Then
                
        ' Lo registramos
        StrCadenaRegistro = "Cadena_de_Registro"
        StrClave = "DatosRegistro"
        If RegSetStringValue(hkeyExistente, StrClave, StrCadenaRegistro) Then
            Unload frmRegister
 	    frmMain.Show
        End If
    End If
End Sub

'FUNCION ADICIONAL PARA VERIFICAL SI ESTA REGISTRADO Y DESEAS COLOCAR ALGUNA FUNCION
Public Sub VerificarRegistro()
    Dim StrClave As String
    Dim StrCadenaRegistro As String
    Dim hkeyExistente As Long
    
    ' Mostramos el formulario de registro
    frmRegistro.Show vbModal

    ' Abrimos la clave del registro
    If RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\MiClave123", hkeyExistente) Then
        
        ' Comprobamos si está registrado con los datos de registro
        StrClave = "DatosRegistro"
        If RegQueryStringValue(hkeyExistente, StrClave, StrCadenaRegistro) Then
            'Abrimos el form principal si es una Versión registrada, lo cual estara completamenta operacional
            frmMain.Caption = "Mi programa Original"
            'Puedes dar muchas funciones segun tus necesedidas de dar permiso o denegarlo
            Exit Sub
        End If
        
        ' Cerramos la clave del registro
        RegCloseKey hkeyExistente
    End If
End Sub

Liston gaston nuestro formulario de registro ya esta listo. Ya te di la base
para que puedas crear un registro basado en dias y no en cantidades.
HASTA UNA NUEVA OPORTUNIDAD... :)

 

http://www.visualbasic-yaltutorial.tk http://www.rgperu.com