Piloter excel avec vb

Bonjour,

Voici un exemple de VBS que vous pourrez adapter
facilement à VB.

'==========================================================================
'
' Fichier Source VBScript
'
' NOM DU FICHIER : <ARBORESCENCE_Sous_EXCEL.VBS>
'
' AUTEUR : Michel Blais
' DATE DE CRÉATION : 2002-11-05
'
' COMMENT: <Compiler dans un fichier EXCEL toutes les informations
' des fichiers d'un lecteur
'(12)==========================================================================
'
'Accèss au dossier d'un disque
'
Const CACHE = "Caché"
Const SYSTEME = "Système"
Const ARCHIVE = "Archive"
Const LECTURE = "Lecture_Seulement"
Const RACCOURCI = "Raccourci"
Const COMPRESSE = "Compressé"

'(23)

Dim oLecteur 'ObjetLecteurDeDisque
Dim oRepertoire 'ObjetRépertoire
Dim oFS 'ObjetFileSystem
Dim sOutput 'Variable d'écriture
Dim oInfoLecteur 'Variable d'information sur le lecteur courant
Dim oInfoFichier '(20)Variable d'information sur le fichier courant
Dim Lecteur 'Variable du lecteur à lire
Dim Disque
Dim FichierEXCEL 'Variable du fichier de sortie
Dim Fichier 'Variable du fichier de sortie
' '(Liste de tous les fichiers du lecteur demandé)
Dim Flag
'

Dim msgTexte 'Variable de message è l'usager
Dim lngTexte 'Variable de la longueur d'une chaine de caractères
'

'
' Déclaration des variables du classeur EXCEL
'
Dim xlApp, xlBook, xlChart, xlWhs, xlRange
Dim iRows, iCols, iRotate

'Debut du programme

Flag = False

msgTexte = "Entrez le nom du fichier : " & vbCrLf & "(ex.: C:\Infofile.xls)"
Fichier = InputBox(msgTexte, "Saisie du fichier à créer", "K:\Info.xls")

Set oFS = CreateObject("Scripting.FileSystemObject")

Set xlApp = CreateObject("Excel.Application")

If (FichierExistant(Fichier)=True) Then
Set xlBook = xlApp.Workbooks.Open(Fichier)
Flag = True
Else
Set xlBook = xlApp.Workbooks.Add
End If

Set xlWks = xlBook.Worksheets(1)
Set xlRange = xlWks.Range("A1:O60000")

Disque = Mid(Fichier, 1, 2)

Set oLecteur = oFS.GetDrive(Disque)

If (oLecteur.IsReady) Then
Lecteur = InputBox("Entrez la lettre du lecteur à lire :", "Saisie du lecteur à lire","K")
Set oLecteur = oFS.GetDrive(Lecteur)

If (oLecteur.IsReady) Then
Call Principal(Fichier)
Else
EnvoiMessage (0)
End If
Else
EnvoiMessage (0)
End If
'
'(76)==========================================================================
'
Sub Principal(ByVal nomFichier)

Dim Plage
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 = "Attr CACHÉ"
xlRange.Cells(1, 11).Value = "Attr SYSTÈME"
xlRange.Cells(1, 12).Value = "Attr ARCHIVE"
xlRange.Cells(1, 13).Value = "Attr LECTURE SEULE"
xlRange.Cells(1, 14).Value = "Attr RACCOURCI"
xlRange.Cells(1, 15).Value = "Attr COMPRESSÉ"

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

If (oLecteur.IsReady) Then

'Lecture des fichiers dans la racine du lecteur
If (oLecteur.RootFolder.Files.Count > 0) Then

For Each oFichier In oLecteur.RootFolder.Files
xlRange.Cells(iRows, 1).Value = oFichier.Name
xlRange.Cells(iRows, 2).Value = oFichier.Type
xlRange.Cells(iRows, 3).Value = oFichier.Size
xlRange.Cells(iRows, 4).Value = oFichier.Path
xlRange.Cells(iRows, 5).Value = oFichier.DateCreated
xlRange.Cells(iRows, 6).Value = oFichier.DateLastAccessed
xlRange.Cells(iRows, 7).Value = oFichier.DateLastModified
xlRange.Cells(iRows, 8).Value = oFichier.ShortName
xlRange.Cells(iRows, 9).Value = oFichier.ShortPath

Call ChercheAttributs (oFichier,CACHE,Reponse)
xlRange.Cells(iRows, 10).Value = Reponse
Call ChercheAttributs (oFichier,SYSTEME,Reponse)
xlRange.Cells(iRows, 11).Value = Reponse
Call ChercheAttributs (oFichier,ARCHIVE,Reponse)
xlRange.Cells(iRows, 12).Value = Reponse
Call ChercheAttributs (oFichier,LECTURE,Reponse)
xlRange.Cells(iRows, 13).Value = Reponse
Call ChercheAttributs (oFichier,RACCOURCI,Reponse)
xlRange.Cells(iRows, 14).Value = Reponse
Call ChercheAttributs (oFichier,COMPRESSE,Reponse)
xlRange.Cells(iRows, 15).Value = Reponse

iRows = (iRows + 1)
Next
End If

'Lecture 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)
Next

xlApp.Visible = True
xlWks.Activate
xlRange.Cells(1, 1).Select

xlApp.DisplayAlerts = False
' xlBook.Save
xlBook.SaveAs nomFichier
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 If
'Wscript.Echo "Ce répertoire contient " & oLecteur.subFolders.Count & " répertoires"
wscript.echo "Fin de traitement :-) "

End Sub
'
'(137)==========================================================================
'
Function FichierExistant(NomFichier)

Dim fso

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

End Function

'
'===============================================================================
'
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
'
'(157)==========================================================================
'
Sub ListeFichier(ByVal oRepertoire)

Dim oDossier
Dim Reponse

On Error Resume Next
If (oRepertoire.Files.Count > 0) Then
For Each oFichier In oRepertoire.Files
'pROPRIÉTÉ
xlRange.Cells(iRows, 1).Value = oFichier.Name
xlRange.Cells(iRows, 2).Value = oFichier.Type
xlRange.Cells(iRows, 3).Value = oFichier.Size
xlRange.Cells(iRows, 4).Value = oFichier.Path
xlRange.Cells(iRows, 5).Value = oFichier.DateCreated
xlRange.Cells(iRows, 6).Value = oFichier.DateLastAccessed
xlRange.Cells(iRows, 7).Value = oFichier.DateLastModified
xlRange.Cells(iRows, 8).Value = oFichier.ShortName
xlRange.Cells(iRows, 9).Value = oFichier.ShortPath

Call ChercheAttributs (oFichier,CACHE,Reponse)
xlRange.Cells(iRows, 10).Value = Reponse
Call ChercheAttributs (oFichier,SYSTEME,Reponse)
xlRange.Cells(iRows, 11).Value = Reponse
Call ChercheAttributs (oFichier,ARCHIVE,Reponse)
xlRange.Cells(iRows, 12).Value = Reponse
Call ChercheAttributs (oFichier,LECTURE,Reponse)
xlRange.Cells(iRows, 13).Value = Reponse
Call ChercheAttributs (oFichier,RACCOURCI,Reponse)
xlRange.Cells(iRows, 14).Value = Reponse
Call ChercheAttributs (oFichier,COMPRESSE,Reponse)
xlRange.Cells(iRows, 15).Value = Reponse
iRows = (iRows + 1)
Next
End If

If (oRepertoire.SubFolders.Count > 0) Then
For Each oDossier In oRepertoire.SubFolders
Call ListeFichier(oDossier)
Next
End If

End Sub
'
'(197)==========================================================================
'

Function ChercheAttributs (ByVal oFichier,ByVal Validation, ByRef Reponse)

On Error Resume Next

Reponse = "Aucun"

Select Case (Validation)
Case (LECTURE)
If (oFichier.Attributes AND 1) Then
Reponse = "Activer" 'Read-only = VRAI
Else
Reponse = "Désactiver" 'Read-only = FAUX
End If

Case (CACHE)
If (oFichier.Attributes AND 2) Then
Reponse = "Activer" 'Hidden file = VRAI
Else
Reponse = "Désactiver" 'Hidden file = FAUX
End If

Case (SYSTEME)
If (oFichier.Attributes AND 4) Then
Reponse = "Activer" 'System file = VRAI
Else
Reponse = "Désactiver" 'System file = FAUX
End If

Case (ARCHIVE)
If (oFichier.Attributes AND 32) Then
Reponse = "Activer" 'Archive bit = VRAI
Else
Reponse = "Désactiver" 'Archive bit = FAUX
End If
Case (RACCOURCI)
If (oFichier.Attributes AND 64) Then
Reponse = "Activer" 'ShortCut = VRAI
Else
Reponse = "Désactiver" 'ShortCut = FAUX
End If
Case (COMPRESSE)
If (oFichier.Attributes AND 2048) Then
Reponse = "Activer" 'Compressed file = VRAI
Else
Reponse = "Désactiver" 'Compressed file = FAUX
End If
Case Else Reponse = "Aucun"

End Select

End Function
'
'==========================================================================
'

Lupin