Sí, poderse se puede, pero usa el CSocketMaster sólo en el servidor, ya que no se pueden cargar index's dinámicamente con el SocketMaster
Un saluduo
Un saluduo
Esta sección te permite ver todos los mensajes escritos por este usuario. Ten en cuenta que sólo puedes ver los mensajes escritos en zonas a las que tienes acceso en este momento.
Mostrar Mensajes Menú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
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
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