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 IfCommand1.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 FUNCIONPublic 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... :) |