Programme Vb qui pilote excel

'==============================================================================================
'
' Fichier Source VBScript
'
' NOM DU FICHIER : <ARBORESCENCE_Sous_EXCEL.VBS>
'
' AUTEUR : Arsène Lupin
' DATE DE CRÉATION  : 2002-11-05
' DATE DE MODIFICATION : 2006-01-17
' Version 3.1
'
' COMMENT: <Compiler dans un fichier EXCEL toutes les informations
'            des fichiers d'un lecteur et/ou d'un répertoire cible
'(Ligne 14)====================================================================================
'
'Accèss au dossier d'un disque
'
Const cteCache = "Caché"
Const cteSysteme = "Système"
Const cteArchive = "cteArchive"
Const cteLecture = "cteLecture_Seulement"
Const cteRaccourci = "cteRaccourci"
Const cteCompresse = "Compressé"
Const ctePlgFitGlobale = "A1:P1"
'
'(Ligne 26)====================================================================================
'
' Déclaration des variables globales du programme
'
Dim oLecteur         'ObjetLecteurDeDisque
Dim oRepertoire      'ObjetRépertoire
Dim oFS              'ObjetFileSystem (Objet du système de fichier)
Dim sOutput          'Variable d'écriture
Dim oInfoLecteur     'Variable d'information sur le lecteur courant
Dim oInfoFichier     'Variable d'information sur le fichier courant
Dim Lecteur          'Variable du lecteur à lire
Dim Disque           'Variable du lecteur à écrire
Dim Fichier          'Variable du fichier de sortie
Dim Flag             'Drapeau (logique)
Dim msgTexte         'Variable de message è l'usager
Dim lngTexte         'Variable de la longueur d'une chaine de caractères
Dim Dossier          'Variable chaine du dossier de départ
Dim DonneesValide    'Variable de la valeur des saisies
'
'(Ligne 45)====================================================================================
'
' Déclaration des variables globales du classeur EXCEL
'
Dim xlApp, xlBook, xlChart, xlRange     'Objets classeur
Dim xlWhs, iRows, iCols, iRotate        'Objets feuille
'
'(Ligne 52)====================================================================================
' Debut du programme
'
'Sub Main()' (Attention, le label n'exite pas en VBS)

    DonneesValide = CaptureEntree(Fichier,Lecteur,Dossier)
    If ( DonneesValide ) Then
        ' Création de l'objet Excel (une classe)
        Set oFS = CreateObject("Scripting.FileSystemObject")
        Set xlApp = CreateObject("Excel.Application")
        ' Vérification de la présence du classeur
        If (FichierExistant(Fichier) = True) Then
            ' Ouverture du classeur
            Set xlBook = xlApp.Workbooks.Open(Fichier)
            Flag = True
        Else
            ' Création du classeur
            xlApp.SheetsInNewWorkbook = 1
            Set xlBook = xlApp.Workbooks.Add
        End If
        ' Positionnement à l'intérieur du classeur
        Set xlWKS = xlBook.Worksheets(1)
        Set xlRange = xlWKS.Range("A1:A65535")
        ' Capture de la lettre du lecteur à écrire
        Disque = Mid(Fichier, 1, 2)
        Set oLecteur = oFS.GetDrive(Disque)
        If (oLecteur.IsReady) Then
            ' Capture de la lettre du lecteur à lire
            Set oLecteur = oFS.GetDrive(Lecteur)
            If (oLecteur.IsReady) Then
                Call Principal(Fichier)
            Else
                EnvoiMessage (0)
            End If
        Else
            EnvoiMessage (0)
        End If
    End if
'
'End Sub (Le label n'exite pas en VBS) Fin de Programme
'
'(Ligne 93)====================================================================================
'
Function CaptureEntree(ByRef FichierCE, ByRef LecteurCE, ByRef DossierCE) 

    On Error Resume next
    Flag = False
    
    FichierCE = ""
    msgTexte = msgTexte & "Attention!" & vbCrLf & vbCrLf
    msgTexte = msgTexte & "Le programme ne gère pas les erreurs!" & vbCrLf & vbCrLf & vbCrLf
    msgTexte = "Entrez le nom du fichier : " & vbCrLf & "(ex.: C:\Infofile.xls)"
    FichierCE = InputBox(msgTexte, "Saisie du fichier à créer", "C:\Info.xls")

    If ( len(FichierCE) >  7 ) Then
        LecteurCE = ""
        LecteurCE = InputBox("Entrez la lettre du lecteur à lire :", "Saisie du lecteur à lire", "C")
        If ( Len(LecteurCE) = 1 ) Then
            DossierCE = ""
            DossierCE = InputBox("Entrez le dossier cible du lecteur à lire :", "Saisie du dossier à lire", "\TEMP")
            If ( len(DossierCE) > 1 ) Then
                CaptureEntree = True
            Else
                DossierCE = ""
                CaptureEntree = true
            End If
        Else
            CaptureEntree = False
	End If
    Else
        CaptureEntree = False
    End if

End Function
'
'(Ligne 127)===================================================================================
'
Sub Principal(ByVal NomFichier)

    Dim Plage
    Dim Valeur
    Dim Boucle
    
    On Error Resume Next
    ' Création de l'En-tête du fichier Excel    
    Call CreationEnTete
    'Placement d'Excel en arrière plan!
    xlApp.WindowState = xlMinimized
    xlApp.ScreenUpdating = False
    
    If (oLecteur.IsReady) Then
        If (Dossier <> "") Then
            'cteLecture à partir du sous-répertoire cible
            Set oRepertoire = oFS.GetFolder(Lecteur & ":" & Dossier)
            xlApp.Visible = True
            xlWKS.Activate
            xlRange.Cells(1, 1).Select
            Call ListeFichier(oRepertoire) ' Routine récursive
        Else
            'cteLecture des fichiers dans la racine du lecteur
            If (oLecteur.RootFolder.Files.Count > 0) Then
                For Each oFichier In oLecteur.RootFolder.Files
                    InsertionDonnees (oFichier)
                Next
            End If
        
            'cteLecture des sous-répertoires dans le lecteur
            For Each oRepertoire In oLecteur.RootFolder.SubFolders
                xlApp.Visible = True
                xlWKS.Activate
                xlRange.Cells(1, 1).Select
                Call ListeFichier(oRepertoire) ' Routine récursive
            Next
        End If
    End If
    MiseEnforme
    'Placement d'Excel en avant plan!
    xlApp.ScreenUpdating = True
    xlApp.WindowState = xlMaximized
    xlRange.Columns("A:A").EntireColumn.AutoFit
    xlRange.Columns("E:G").EntireColumn.AutoFit

    
    'Fermeture du fichier Excel
    Call FermetureExcel()
    wscript.echo "Fin de traitement :-) "

End Sub
'
'(Ligne 178)===================================================================================
'
Function FichierExistant(NomFichier)

    Dim fso

    Set fso = CreateObject("Scripting.FileSystemObject")
    FichierExistant = fso.FileExists(NomFichier)
    Set fso = Nothing

End Function
'
'(Ligne 190)===================================================================================
'
Function EnvoiMessage(ByVal Chiffre)

    Select Case Chiffre
        Case 0:  msgTexte = "Lecteur non disponible !"
        Case 1:  msgTexte = "Disponible !"
        Case 2:  msgTexte = "Disponible !"
        Case 3:  msgTexte = "Disponible !"
        Case 4:  msgTexte = "Disponible !"
        Case 5:  msgTexte = "Disponible !"
        Case 6:  msgTexte = "Disponible !"
        Case Else:       msgTexte = "Code d'erreur inexistant !"
    End Select
                        
    Wscript.Echo msgTexte

End Function
'
'(Ligne 209)===================================================================================
'
Sub ListeFichier(ByVal oRepertoire)    ' Routine récursive

    Dim oDossier

    On Error Resume Next

    If (oRepertoire.Files.Count > 0) Then
        For Each oFichier In oRepertoire.Files
            InsertionDonnees (oFichier)
        Next
    End If

    If (oRepertoire.SubFolders.Count > 0) Then
        For Each oDossier In oRepertoire.SubFolders
            Call ListeFichier(oDossier)
        Next
    End If
        
End Sub
'
'(Ligne 231)===================================================================================
'
Function ChercheAttributs(ByVal oFichier, ByVal Validation, ByRef Repons)

    On Error Resume Next

    Repons = "Aucun"

    Select Case (Validation)
        Case (cteLecture):
            If (oFichier.Attributes And 1) Then
                Repons = "Activer" 'Read-only = VRAI
            Else
                Repons = "Désactiver" 'Read-only = FAUX
            End If

        Case (cteCache):
            If (oFichier.Attributes And 2) Then
                Repons = "Activer" 'Hidden file = VRAI
            Else
                Repons = "Désactiver" 'Hidden file = FAUX
            End If

        Case (cteSysteme):
            If (oFichier.Attributes And 4) Then
                Repons = "Activer" 'System file = VRAI
            Else 
                Repons = "Désactiver" 'System file = FAUX
            End If

        Case (cteArchive):
            If (oFichier.Attributes And 32) Then 
                Repons = "Activer" 'cteArchive bit = VRAI
            Else 
                Repons = "Désactiver" 'cteArchive bit = FAUX
            End If

        Case (cteRaccourci):
            If (oFichier.Attributes And 64) Then 
                Repons = "Activer" 'ShortCut = VRAI
            Else 
                Repons = "Désactiver" 'ShortCut = FAUX
            End If

        Case (cteCompresse):
            If (oFichier.Attributes And 2048) Then 
                Repons = "Activer" 'cteCompressed file = VRAI
            Else 
                Repons = "Désactiver" 'cteCompressed file = FAUX
            End If

        Case Else: Repons = "Aucun"
    
    End Select

End Function
'
'(Ligne 288)===================================================================================
'
Function CreationEnTete()

    Dim Valeur
    Dim Boucle
    
    On Error Resume Next
    
    If (Flag = False) Then
        'Création de l'en-tête du fichier EXCEL
        xlRange.Cells(1, 1).Value = "Nom Fichier"
        xlRange.Cells(1, 2).Value = "Type Fichier"
        xlRange.Cells(1, 3).Value = "Grandeur"
        xlRange.Cells(1, 4).Value = "Chemin d'accès"
        xlRange.Cells(1, 5).Value = "Date Créé"
        xlRange.Cells(1, 6).Value = "Date Accédé"
        xlRange.Cells(1, 7).Value = "Date Modifié"
        xlRange.Cells(1, 8).Value = "Nom cours"
        xlRange.Cells(1, 9).Value = "Chemin cours"
        xlRange.Cells(1, 10).Value = "Version"
        xlRange.Cells(1, 11).Value = "Attr Caché"
        xlRange.Cells(1, 12).Value = "Attr Système"
        xlRange.Cells(1, 13).Value = "Attr Archive"
        xlRange.Cells(1, 14).Value = "Attr Lecture seule"
        xlRange.Cells(1, 15).Value = "Attr Raccourci"
        xlRange.Cells(1, 16).Value = "Attr compressé"
        ' Dans Sub MiseEnForme la plage est ("A1:P1")
        ' Défini par la constante ctePlgFitGlobale
        iRows = 2
    Else
        Boucle = 1
        Valeur = xlRange.Cells(1, 1).Value
        While (Valeur <> "")
            Boucle = (Boucle + 1)
            Valeur = xlRange(Boucle, 1)
        Wend
        iRows = Boucle
    End If

End Function
'
'(Ligne 330)===================================================================================
'
Function MiseEnForme()

    xlRange.Columns(ctePlgFitGlobale).EntireColumn.AutoFit
    xlRange("A2").Select

End Function
'
'(Ligne 339)===================================================================================
'
Function InsertionDonnees(ByVal CeFichier)

    On Error Resume Next

    Dim Reponse
                    
    xlRange.Cells(iRows, 1).Value = CeFichier.Name
    xlRange.Cells(iRows, 2).Value = CeFichier.Type
    xlRange.Cells(iRows, 3).Value = CeFichier.Size
    xlRange.Cells(iRows, 4).Value = CeFichier.Path
    xlRange.Cells(iRows, 5).Value = CeFichier.DateCreated
    xlRange.Cells(iRows, 6).Value = CeFichier.DateLastAccessed
    xlRange.Cells(iRows, 7).Value = CeFichier.DateLastModified
    xlRange.Cells(iRows, 8).Value = CeFichier.ShortName
    xlRange.Cells(iRows, 9).Value = CeFichier.ShortPath
    xlRange.Cells(iRows, 10).Value = ChercheVersion(CeFichier.Name)
            
    Call ChercheAttributs(CeFichier, cteCache, Reponse)
    xlRange.Cells(iRows, 11).Value = Reponse
    Call ChercheAttributs(CeFichier, cteSysteme, Reponse)
    xlRange.Cells(iRows, 12).Value = Reponse
    Call ChercheAttributs(CeFichier, cteArchive, Reponse)
    xlRange.Cells(iRows, 13).Value = Reponse
    Call ChercheAttributs(CeFichier, cteLecture, Reponse)
    xlRange.Cells(iRows, 14).Value = Reponse
    Call ChercheAttributs(CeFichier, cteRaccourci, Reponse)
    xlRange.Cells(iRows, 15).Value = Reponse
    Call ChercheAttributs(CeFichier, cteCompresse, Reponse)
    xlRange.Cells(iRows, 16).Value = Reponse

    iRows = (iRows + 1)
    If (iRows > 65534) Then
        xlApp.ActiveWorkbook.Worksheets.Add
        Set xlWKS = xlBook.Worksheets(1)
        Set xlRange = xlWKS.Range("A1:A65535")
        iRows = 2
    End If

End Function
'
'(Ligne 381)===================================================================================
'
Function FermetureExcel()

    xlApp.Visible = True
    xlWKS.Activate
    xlRange.Cells(1, 1).Select
    xlApp.DisplayAlerts = False
    xlBook.SaveAs Fichier
    xlApp.Quit
    xlApp.DisplayAlerts = True

    Set xlRange = Nothing
    Set xlChart = Nothing
    Set xlWKS = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    iRows = 0
    iCols = 0

End Function