Liens utiles

FAQVBS
W3schools online web tutorials
Edietru : Notepad++

Tableaux

Charger un fichier dans un tableau

Sub ChargerFichierDansTAB_1 (sFichier, tt, nbCol, sDelim)
REM ==================================
REM Charger un fichier dans un tableau
REM nbCol : nb de colonnes sur une ligne
REM sSep : séparateur d'éléments sur une ligne
REM ==================================
Dim s, t, i, u
s = FileReadAll(sFichier)
t = Split(s, vbCrLf)
ReDim tt(UBound(t)*nbCol-1)
For i=0 To UBound(t)
u = Split(t(i), sDelim)
For j=0 To nbCol-1
tt(i*nbCol+j) = u(j)
Next
Next
End Sub

Différences entre deux tableaux

'à utiliser pour l'AD, dans un fichier HTM :
'différences groupes d'un utilisateur à l'autres
'différences des memebres de deux groupes

'à utiliser dans Excel dans une procédure VBA

t= Array(_
        "m", "abc", "12", _
        "a", "abc", "12", _
        "f", "abc", "12")
u= Array( _
        "f", "abc", "12", _
        "a", "abc", "12", _
        "m", "abc", "1")

Differences_Between_Two_Tables t, u, 3

Sub Differences_Between_Two_Tables(t, u, widthTab)
    REM ==================================
    REM list the differences, common lines
    REM between two tables
    REM t et u ont la même largeur widthTab (=nb de colonnes)
    REM ==================================
    'brute force :
    'browse each line of each tables
    Dim i, j, b_t_Present_in_u
    Dim k
    Dim bCommonLines
    ReDim tt(UBound(t)/widthTab)     'Dim only makes an error
    ReDim uu(UBound(u)/widthTab)    'ReDim necessary

    For i=0 To UBound(t) Step widthTab
    b_t_Present_in_u = FALSE
    For j=0 To UBound(u) Step widthTab
        bCommonLines=TRUE
        For k=1 To widthTab
           'prendre les widthTab de chaque enregistrement
           'attention sensible à la casse !
           If t(i+k-1) <> u(j+k-1) Then bCommonLines=FALSE
        Next
        If bCommonLines Then
           b_t_Present_in_u =TRUE
           Exit For
        End If
    Next
    If b_t_Present_in_u Then
       'marquer élément i de t
       '     et élément j de u comme éléments communs
       Wscript.Echo "Ligne " & i/widthTab & " de t commune à ligne " & j/widthTab & " de u."
       tt(i/widthTab) = "1" 'common lines
       uu(j/widthTab) = "1" 'common lines
       Else
       'marquer élément i de t unique
       Wscript.Echo "Ligne " & i/widthTab & " de t unique."
       tt(i/widthTab) = "1" 'unique line (useless, default value)
    End If
    Next

    'here all tt()=0 and uu()=0 means unique lines in t an u
End Sub

QuickSort

Sub QSort_Simple(t,deb,fin,numCol,nbCol)
REM ========================================
REM = Trier un tableau linéaire, des indices
REM = deb à fin, de largeur nbCol
REM = t(0) : vide (ou indicatif)
REM = exemple : pour trier en entier
REM = un tableau à trois colonnes,
REM = sur la 2ème colonne,
REM = contenant 25 enregistrements (lignes)
REM = et qui commence à l'indice 1
REM = utiliser : QSort_Simple t,1,25,2,3
REM ========================================
'1. segmenter le tableau au milieu
Dim i, j, c, p, z
c = (deb + fin) \ 2        'divison entière
Do
i = deb: j = fin
While LCase(t((i-1)*nbCol+numCol)) <= LCase(t((c-1)*nbCol+numCol)) And i < c:i = i + 1:Wend
While LCase(t((j-1)*nbCol+numCol)) >= LCase(t((c-1)*nbCol+numCol)) And j > c:j = j - 1:Wend
   'échanger les valeurs
   If i < j Then
    For z=1 To nbCol   'à verifier !!! z=1
        p = t( (j-1)*nbCol+z )
        t( (j-1)*nbCol+z ) = t( (i-1)*nbCol+z )
        t( (i-1)*nbCol+z ) = p
    Next
   End If
   i = i + 1: j = j - 1
Loop While i < j
'2. appels récursifs
If j > deb Then QSort_Simple t,deb,j,numCol,nbCol
If i < fin Then QSort_Simple t,i,fin,numCol,nbCol
End Sub

Fichiers

Ligne à faire figurer dans la fonction ou bien dans les déclarations de varaibles en début de fichier
Set oFSO = CreateObject("Scripting.FileSystemObject")

Déplacer des fichiers suivant leur extension

Sub Move_Files_Ext_To_Folder(sFolder, sExtensionFichier)
    REM ============================
    REM move the files to the folders created
    REM (intérêt relatif)
    REM ============================
    Dim oFSO, f, dossier, nbDossiersCrees, dossier_a_creer, fichiers, fichier, nom, p, nbFichiersDeplaces
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set dossier = oFSO.GetFolder(sFolder)
    set fichiers = dossier.Files

    For Each fichier in fichiers
    'Wscript.Echo "fichier : " & fichier.Name
    nom = fichier.Name
    If Right(LCase(fichier), 4)= LCase(sExtensionFichier) Then
        p = Instr(nom, " - ")
        If p>0 Then
        dossier_a_creer = Left(nom, p-1)
        If oFSO.FolderExists(dossier_a_creer) Then
           Wscript.Echo "Fichier : " & nom & ", dossier : " & dossier_a_creer
           If oFSO.FileExists(nom) Then
            oFSO.MoveFile nom, dossier_a_creer & "\" 'backslash needed !!!
            nbFichiersDeplaces = nbFichiersDeplaces + 1
           End If
        End If
        End If
    End If
    Next
    Set f = Nothing
    Set oFSO = Nothing
    Wscript.Echo nbFichiersDeplaces & " fichiers déplacés."
End Sub

Lire tout un fichier

Function FileReadAll(sFile)
REM ========================================
REM = Renvoie le contenu complet d'un fichier texte
REM ========================================
proc = "fn_FileReadAll"
On Error Resume Next
Dim f
Set f = oFSO.OpenTextFile(sFile)
If Err Then
Msgbox "Erreur de lecture du fichier " & sFile & vbCrLf & "Fin du programme."
WScript.Quit(0)
End If
FileReadAll = f.ReadAll
Set f = Nothing
End Function

Lister les dossiers vides

Dim g_nbDossiers_a_Supprimer
ListEmptyFolders "d:\"
Wscript.Echo g_nbDossiers_a_Supprimer & " dossiers vides trouvés."

Sub ListEmptyFolders(sFolder)
    REM ============================
    REM deletes empty subfolders
    REM recursive procedure
    REM ============================
    On Error Resume Next 'pb sur dossiers spéciaux
    Dim oFSO, f, d, dossier, folders
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set f = oFSO.GetFolder(sFolder)
    set folders = f.SubFolders

    For Each d in folders
    ListEmptyFolders oFSO.GetAbsolutePathName(d)
    If oFSO.GetFolder(oFSO.GetAbsolutePathName(d)).Size = 0 Then
    g_nbDossiers_a_Supprimer = g_nbDossiers_a_Supprimer + 1
    Wscript.Echo g_nbDossiers_a_Supprimer & ". " & d
    End If
    Next

    Set f = Nothing
    Set oFSO = Nothing
End Sub

Sauver un fichier

Sub SaveToFile (sTexte, sFile)
REM ========================================
REM = Sauvegarde un texte dans un fichier
REM ========================================
Dim oFSO, f1
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set f1 = oFSO.CreateTextFile(sFile)
f1.Write sTexte
f1.Close
Set f1 = Nothing
Set oFSO = Nothing
End Sub

Supprimer des dossiers vides

Sub DeleteEmptyFolders(sFolder)
    REM ============================
    REM deletes empty subfolders, supprimer des sous-dossiers vides
    REM ============================
    Dim oFSO, f, d, dossier, folders, nbDossiersSupprimes
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set f = oFSO.GetFolder(sFolder)
    set folders = f.SubFolders

    For Each d in folders
    If d.Size = 0 Then
    nbDossiersSupprimes = nbDossiersSupprimes + 1
    oFSO.DeleteFolder d
    End If
    Next

    Set f = Nothing
    Set oFSO = Nothing
    Wscript.Echo nbDossiersSupprimes & " dossiers supprimés."
End Sub