[SOURCE] Autodestrucción pasados X días

[jmordenata]

Hola, agradezco la ayuda a Cassiani que me ha guiado en como hacer la autodestrucción, etc... Bueno, aquí va el código

• Un formulario
• Un módulo llamado modReg

En el formulario, ponemos:

Código (vb) [Seleccionar] Expandir

Dim plazo As Integer
Dim dia As Variant
Dim exp As String
Dim exp2 As Variant
Dim dia_mes As Integer
Dim mes As Integer
Dim res As Long
Dim añadir1 As Boolean
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpoperation As String, _
ByVal lpfile As String, ByVal lpparameters As String, _
ByVal lpdirectory As String, ByVal nshowcmd As Long) As Long


Private Sub Form_Load()
plazo = 3 'el numero de dias que se van a dar hasta que se autodestruya
dia = Split(Date, "/") 'partimos la cadena date...
Expira 'llamamos a la funcion para k se refreske la variable añadir1
If GetStringKey(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion") = "" Then 'si no existe la clave...
    If añadir1 = True Then 'si nos pasamos un mes...
        Call Reg_Crea_KeyConValor(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion", Expira & "/" & Month(Date) + 1) 'la creamos
        exp = Expira & "/" & Month(Date) + 1 'para que no nos salte el error
    Else 'si no...
        Call Reg_Crea_KeyConValor(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion", Expira & "/" & dia(1)) 'la creamos
        exp = dia(0) + plazo & "/" & dia(1) 'para que no nos salte el error
    End If
Else
    exp = GetStringKey(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion") 'si existe la clave la guardamos en esta variable
End If
exp2 = Split(exp, "/") 'partimos la variable exp
dia_mes = exp2(0) 'cargamos en la variable dia_mes el dia en el k expira
mes = exp2(1) 'cargamos en la variable mes el mes en el que expira
If mes = Month(Date) Then 'si el mes en el que estamos es IGUAL al mes en el k expira...
    If dia_mes < dia(0) Then  'si el dia actual es mayor de la fecha de expiracion..
        MsgBox "Tu plazo de " & plazo & " dia(s) se ha acabado.", vbExclamation, "Lanzador" 'hasta luego lucas!
        CrearBat 'Creamos el fichero .bat
        Call Reg_Borra_Key(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion") 'just before madness...
        Shell "autodestruccion.bat", vbHide 'nos autodestruimos
    ElseIf dia_mes = dia(0) Then 'si el dia actual es igual a la fecha de expiracion...
        MsgBox "Tu plazo de " & plazo & " dia(s) se ha acabado.", vbExclamation, "Lanzador" 'hasta luego lucas!
        CrearBat 'Creamos el fichero .bat
        Call Reg_Borra_Key(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion") 'just before madness...
        Shell "autodestruccion.bat", vbHide 'nos autodestruimos
    Else 'si todavía queda tiempo...
        MsgBox "Te quedan " & dia_mes - dia(0) & " dia(s) de plazo. Ahora se iniciará el programa.", vbInformation, "Lanzador" 'decimos cuanto queda
        res = ShellExecute(Me.hwnd, "open", "C:\WINDOWS\EJERC01.TMW", "", "", sw_showdefault)
    End If
ElseIf mes < Month(Date) Then 'si el mes actual es más mayor que el mes en el que expira significa NECESARIAMENTE que se a pasado la fecha
    MsgBox "Tu plazo de " & plazo & " dia(s) se ha acabado.", vbExclamation, "Lanzador" 'hasta luego lucas!
    CrearBat 'Creamos el fichero .bat
    Call Reg_Borra_Key(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion") 'just before madness...
    Shell "autodestruccion.bat", vbHide 'nos autodestruimos
ElseIf mes > Month(Date) Then 'si el mes de expiración es mayor que el mes actual todavía no se ha acacbado el plazo
    MsgBox "Ahora se iniciará el programa.", vbInformation, "Lanzador" 'decimos cuanto queda
    res = ShellExecute(Me.hwnd, "open", "C:\WINDOWS\EJERC01.TMW", "", "", sw_showdefault)
End If
End Sub

Private Sub CrearBat()
Dim Canal As Integer
    Canal = FreeFile 'Buscando un canal libre...
    Open "autodestruccion.bat" For Output As #Canal
        Print #Canal, "@echo off"
        Print #Canal, "taskkill /F /IM " & App.EXEName & ".exe"
        'Print #Canal, "taskkill /F /IM proceso_que_matar.exe"
        'Aqui nos autoeliminamos
        Print #Canal, "del " & App.EXEName & ".exe"
        Print #Canal, "del C:\WINDOWS\EJERC01.TMW"
        'Aqui el bat se suicida
        Print #Canal, "del autodestruccion.bat"
    Close #Canal
End Sub
Public Function Expira() As Byte
    Select Case Month(Date)
        Case 1, 3, 5, 7, 8, 10, 12:
            If Day(Date) = 31 Then
                Expira = plazo
                añadir1 = True
            Else
                Expira = Day(Date) + plazo
                If Expira > 31 Then
                    Expira = Expira - 31
                    añadir1 = True
                End If
            End If
        Case 2
            If Bisiesto(Year(Date)) = True Then
                If Day(Date) = 29 Then
                    Expira = plazo
                    añadir1 = True
                Else
                    Expira = Day(Date) + plazo
                    If Expira > 29 Then
                        Expira = Expira - 29
                        añadir1 = True
                    End If
                End If
            Else
                If Day(Date) = 28 Then
                    Expira = plazo
                Else
                    Expira = Day(Date) + plazo
                    If Expira > 28 Then
                        Expira = Expira - 28
                        añadir1 = True
                    End If
                End If
            End If
        Case Else
            If Day(Date) = 30 Then
                Expira = plazo
            Else
                Expira = Day(Date) + plazo
                If Expira > 30 Then
                    Expira = Expira - 30
                    añadir1 = True
                End If
            End If
    End Select
End Function

Public Function Bisiesto(Año As Integer) As Boolean
On Error GoTo nError
'Los años divisibles por 4 son bisiestos, pero cada 400 años se deben eliminar 3 _
bisiestos. Para ello, no son bisiestos los que se dividen por 100, menos los que se _
dividen por 400, que sí son bisitestos.

    If Año Mod 4 = 0 Then
        If (Año Mod 100 = 0) And Not (Año Mod 400 = 0) Then
            Bisiesto = False
        Else
            Bisiesto = True
        End If
    Else
        Bisiesto = False
    End If
    'Salimos de la función
    Exit Function

nError:
    Bisiesto = False
End Function



Y en el módulo:

Código (vb) [Seleccionar] Expandir

Option Explicit

Public Carpetas_Registro As String
Public Keys_Registro As String
Public READ_Valor_Key As String
Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
Global Const REG_SZ = 1
Global Const REG_BINARY = 3
Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_CONFIG = &H80000005
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_DYN_DATA = &H80000006
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003
Global Const ERROR_SUCCESS = 0&
Global Const KEY_ENUMERATE_SUB_KEYS = &H8
Global Const KEY_QUERY_VALUE = &H1
Public Declare Sub CopyMemory32 Lib "Kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function 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 Byte, lpcbData As Long) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Public Sub Reg_Crea_KeyConValor(hKey As Long, carpeta As String, Nombre_Key As String, contenido_key As String)
Dim res
RegOpenKey hKey, carpeta, res
RegSetValueEx res, Nombre_Key, 0, REG_SZ, ByVal contenido_key, Len(contenido_key)
RegCloseKey res
End Sub

Public Sub Reg_Borra_Key(hKey As Long, strPath As String, strValue As String)
Dim ret
RegOpenKey hKey, strPath, ret
RegDeleteValue ret, strValue
RegCloseKey ret
End Sub

Public Sub Reg_Abre_Carpeta(hKey As Long, nombre_folderkey As String)
Dim res
RegOpenKeyEx HKEY_CURRENT_USER, nombre_folderkey, 0, 0, res
End Sub
Public Sub Reg_Cierra_carpeta()
Dim res
RegCloseKey HKEY_CURRENT_USER
End Sub

Public Sub Reg_Lee_Keys(hKey As Long, ruta As String)

Dim valuename As String
    Dim valuelen As Long
    Dim datatype As Long
    Dim Data(0 To 254) As Byte
    Dim datalen As Long
    Dim datastring As String

    Dim Index As Long
    Dim c As Long
    Dim retVal As Long
    READ_Valor_Key = ""
    retVal = RegOpenKeyEx(hKey, ruta, 0, KEY_QUERY_VALUE, hKey)
    If retVal <> 0 Then
       
        'End
    End If
   
    Index = 0
    While retVal = 0

        valuename = Space(255)
        valuelen = 255
        datalen = 255

        retVal = RegEnumValue(hKey, Index, valuename, valuelen, 0, datatype, Data(0), datalen)
        If retVal = 0 Then
            valuename = Left(valuename, valuelen)
           
            READ_Valor_Key = READ_Valor_Key & "Key: " & valuename & vbCrLf
            Select Case datatype
            Case REG_SZ
                datastring = Space(datalen - 1)
                CopyMemory32 ByVal datastring, Data(0), datalen - 1
               
               
                READ_Valor_Key = READ_Valor_Key & "      Valor: " & datastring & vbCrLf
            Case REG_BINARY
                Dim ttStr As String
                ttStr = ""
               
                For c = 0 To datalen - 1
                    datastring = Hex(Data(c))
                    If Len(datastring) < 2 Then datastring = _
                        String(2 - Len(datastring), "0") & datastring
                   
                    ttStr = ttStr & datastring & " "
                Next c
               
            READ_Valor_Key = READ_Valor_Key & "      Valor: " & ttStr & vbCrLf
            Case Else
               
            End Select
        End If
        Index = Index + 1
    Wend
    retVal = RegCloseKey(hKey)
End Sub

Public Sub Reg_Lee_carpetas(hKey As Long, carpeta As String)
Dim keyname As String
Dim keylen As Long
Dim ClassName As String
Dim classlen As Long
Dim lastwrite As FILETIME
Carpetas_Registro = ""
Dim Index As Long
Dim retVal As Long
retVal = RegOpenKeyEx(hKey, carpeta, 0, KEY_ENUMERATE_SUB_KEYS, hKey)
    If retVal <> 0 Then
    End If
    Index = 0
    While retVal = 0
      keyname = Space(255): ClassName = Space(255)
      keylen = 255: classlen = 255
      retVal = RegEnumKeyEx(hKey, Index, keyname, keylen, ByVal 0, ClassName, classlen, lastwrite)
      If retVal = 0 Then
        keyname = Left(keyname, keylen)
        ClassName = Left(ClassName, classlen)
        If carpeta = "" Then
            Carpetas_Registro = Carpetas_Registro & keyname & vbCrLf
        Else
            Carpetas_Registro = Carpetas_Registro & carpeta & "\" & keyname & vbCrLf
        End If
       End If
      Index = Index + 1
    Wend
    retVal = RegCloseKey(hKey)
End Sub

Public Sub Reg_Leer_ValorKey(hKey As Long, Carpeta_Key As String, Nombre_Key As String)
Dim cadena As String
cadena = String(255, Chr(0))
Dim res As Long
RegOpenKey hKey, Carpeta_Key, res
RegQueryValueEx res, Nombre_Key, 0, REG_SZ, ByVal cadena, Len(cadena)


RegCloseKey res
End Sub

Public Sub Reg_Borra_Carpeta(hKey As String, del_carpeta As String)
RegDeleteKey hKey, del_carpeta
End Sub

Public Sub Reg_Crear_carpeta(hKey As Long, Crear_carpeta As String)
Dim res As Long
RegCreateKey hKey, Crear_carpeta, res

RegCloseKey res
End Sub

Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String)
    Dim lResult As Long
    Dim lValueType As Long
    Dim strBuf As String
    Dim lDataBufSize As Long
    Dim intZeroPos As Integer
   
    lResult = RegQueryValueEx(hKey, strValueName, 0&, lValueType, ByVal 0&, lDataBufSize)
    If lResult = ERROR_SUCCESS Then
        If lValueType = REG_SZ Then
            strBuf = String(lDataBufSize, " ")
            lResult = RegQueryValueEx(hKey, strValueName, 0&, 0&, ByVal strBuf, lDataBufSize)
            If lResult = ERROR_SUCCESS Then
                intZeroPos = InStr(strBuf, Chr$(0))
                If intZeroPos > 0 Then
                   RegQueryStringValue = Left$(strBuf, intZeroPos - 1)
                Else
                   RegQueryStringValue = strBuf
                End If
            End If
        End If
    End If
End Function

Public Function GetStringKey(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String) As String
    Dim keyhand&
    Dim datatype&
    Dim r
   
    r = RegOpenKey(hKey, strPath, keyhand&)
    GetStringKey = RegQueryStringValue(keyhand&, strValue)
    r = RegCloseKey(keyhand&)
End Function





UPDATE: He actualizado el código (gracias Cassiani) para que detecte si se pasa de un mes y salta al siguiente

Espero que os guste

Un saluduo

[jmordenata]

Vale, me acabo de dar cuenta de que si la primera ejecución es un 31, no se dará cuenta de que ha expirado... como lo puedo solucionar?

Muchas gracias...

un saluduo

[jmordenata]

He avanzado un poco.

Código [Seleccionar] Expandir

Private Sub Form_Load()
Dim dia As Variant
Dim plazo As Integer
Dim exp As String
Dim exp2 As Variant
Dim dia_mes As Integer
Dim mes As Integer
plazo = 1 'el numero de dias que se van a dar hasta que se autodestruya
dia = Split(Date, "/") 'partimos la cadena date...

If GetStringKey(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion") = "" Then 'si no existe la clave...
Call Reg_Crea_KeyConValor(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion", dia(0) + plazo & "/" & dia(1)) 'la creamos
exp = dia(0) + plazo & "/" & dia(1) 'para que no nos salte el error
Else
exp = GetStringKey(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion") 'si existe la clave la guardamos en esta variable
End If
exp2 = Split(exp, "/") 'partimos la variable exp
dia_mes = exp2(0) 'cargamos en la variable dia_mes el dia en el k expira
mes = exp2(1) 'cargamos en la variable mes el mes en el que expira
If dia_mes < dia(0) Then  'si el dia actual es mayor de la fecha de expiracion...
    MsgBox "Tu plazo de " & plazo & " dia(s) se ha acabado.", vbExclamation, "Lanzador" 'hasta luego lucas!
    CrearBat 'Creamos el fichero .bat
    Call Reg_Borra_Key(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion") 'just before madness...
    Shell "autodestruccion.bat", vbHide 'nos autodestruimos
ElseIf dia_mes = dia(0) Then 'si el dia actual es igual a la fecha de expiracion...
    MsgBox "Tu plazo de " & plazo & " dia(s) se ha acabado.", vbExclamation, "Lanzador" 'hasta luego lucas!
    CrearBat 'Creamos el fichero .bat
    Call Reg_Borra_Key(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "Expiracion") 'just before madness...
    Shell "autodestruccion.bat", vbHide 'nos autodestruimos
Else 'si todavía queda tiempo...
    MsgBox "Te quedan " & dia_mes - dia(0) & " dia(s) de plazo. Ahora se iniciará el programa.", vbInformation, "Lanzador" 'decimos cuanto queda
     'abrimos el programa
End If
End Sub

Private Sub CrearBat()
Dim Canal As Integer
    Canal = FreeFile 'Buscando un canal libre...
    Open "autodestruccion.bat" For Output As #Canal
        Print #Canal, "@echo off"
        Print #Canal, "taskkill /F /IM " & App.EXEName & ".exe"
        'Print #Canal, "taskkill /F /IM proceso_que_matar.exe"
        'Aqui nos autoeliminamos
        Print #Canal, "del " & App.EXEName & ".exe"
        'Print #Canal, "del C:\ruta_al_ejecutable\ejecutable.exe"
        'Aqui el bat se suicida
        Print #Canal, "del autodestruccion.bat"
    Close #Canal
End Sub


Supongo que para saber si un mes tiene 30 o 31 días habrá que usar arrays... y eso   se escapa de mis humildes conocimientos xD

Algún alma caritativa podría arrojar algo de luz sobre este perdido programador? xD

un saluduo

[cassiani]

Supongo que para saber si un mes tiene 30 o 31 días habrá que usar arrays... y eso   se escapa de mis humildes conocimientos xD

Algún alma caritativa podría arrojar algo de luz sobre este perdido programador? xD

Quizas esto te sirva!!

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Sub Form_Load()
    MsgBox "Expira el día " & Expira
End Sub

Public Function Expira() As Byte
    Select Case Month(Date)
        Case 1, 3, 5, 7, 8, 10, 12:
            If Day(Date) = 31 Then
                Expira = 1
            Else
                Expira = Day(Date) + 1
            End If
        Case 2
            If Bisiesto(Year(Date)) = True Then
                If Day(Date) = 29 Then
                    Expira = 1
                Else
                    Expira = Day(Date) + 1
                End If
            Else
                If Day(Date) = 28 Then
                    Expira = 1
                Else
                    Expira = Day(Date) + 1
                End If
            End If
        Case Else
            If Day(Date) = 30 Then
                Expira = 1
            Else
                Expira = Day(Date) + 1
            End If
    End Select
End Function

Public Function Bisiesto(Año As Integer) As Boolean
On Error GoTo nError
'Los años divisibles por 4 son bisiestos, pero cada 400 años se deben eliminar 3 _
bisiestos. Para ello, no son bisiestos los que se dividen por 100, menos los que se _
dividen por 400, que sí son bisitestos.
   
    If Año Mod 4 = 0 Then
        If (Año Mod 100 = 0) And Not (Año Mod 400 = 0) Then
            Bisiesto = False
        Else
            Bisiesto = True
        End If
    Else
        Bisiesto = False
    End If
    'Salimos de la función
    Exit Function

nError:
    Bisiesto = False
End Function


[jmordenata]

¿Puedo amarte siendo macho? xDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD



muchas gracias!!!

[cassiani]

¿Puedo amarte siendo macho? xDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD



muchas gracias!!!

Nooo tranquilo!!! dejémoslo de ese tamaño ja, ja, me conformo con seguir ayudandote, 

¡S4lu2! 

[jmordenata]

Bueno, muchas gracias de cualkier forma... oye conoces algun Joiner que te permita seleccionar si ejecutar o no un programa con el joiner, pueda copiar archivos a C:/windows y se autodestruya después de ejecutarlo por primera vez? xDDD el cactus joiner 2.71 es una beta y no joinea...

Un saluduo, xDDDD

[LeandroA]

hola muy bien. me quedo una duda con esta linea

    res = ShellExecute(Me.hwnd, "open", "C:\WINDOWS\EJERC01.TMW", "", "", sw_showdefault)

esto seria para mostrar un ejemplo como para ejectuar otra cosa?

Saludos

[jmordenata]

LeandroA, esque mira, te explico:

En realidad este "autodestructor" lo voy a usar para distribuir archivos y que se puedan ejecutar durante... una semana, por ejemplo. Si se ha pasado el plazo, se crea el BAT y adios. Si no, se ejecuta.

Entonces sí, es un ejemplo. Pero a lo largo de el día de hoy voy a publicar el editor, y si me sale bien lo compilo todo, le pongo una interfaz bonita y subo el codigo a mi hosting.

Un saludo y gracias a los 2 por interesaros.

Un saluduo

[Sh4k4]

y se le cambio la extension por com?