Code pour la durée

Version imprimable

Code pour la durée

Bonjour.

J'ai trouvé ce code qui liste les fichiers d'un répertoire sur le site il fonctionne bien. Merci au passage à l'auteur.

Malgré mes recherches je n'ai pas trouvé comment ajouter le code qui

permet d'obtenir la durée (par exemple d'une vidéo),(.avi) ou autre

Si vous savez alors merci à vous, je suis preneur de toute solution.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
Option Explicit
 
Sub TestListeFichiers()
    Dim Dossier As String
 
    'Définit le répertoire pour débuter la recherche de fichiers.
    '(Attention à ne pas indiquer un répertoire qui contient trop de sous-dossiers ou de
    'fichiers, sinon le temps de traitement va être très long).
    Dossier = "C:\Documents and Settings\mimi\dossier"
 
    'Appelle la procédure de recherche des fichiers
    ListeFichiers Dossier
 
    'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
    Columns("A:E").AutoFit
    MsgBox "Terminé"
End Sub
 
Sub ListeFichiers(Repertoire As String)
    '
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
        'Dans l'éditeur de macros (Alt+F11):
        'Menu Outils
        'Références
        'Cochez la ligne "Microsoft Scripting RunTime".
        'Cliquez sur le bouton OK pour valider.
 
    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i As Long
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
 
    'Récupère le numéro de la dernière ligne vide dans la colonne A.
    i = Range("A65536").End(xlUp).Row + 1
 
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        'Inscrit le nom du fichier dans la cellule
        Cells(i, 1) = FileItem.Name
        'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), _
            Address:=FileItem.ParentFolder & "\" & FileItem.Name
        'Indique la date de création
        Cells(i, 2) = FileItem.DateCreated
        'Indique la date de dernier acces
        Cells(i, 3) = FileItem.DateLastAccessed
        'Indique la date de dernière modification
        Cells(i, 4) = FileItem.DateLastModified
        'Nom du répertoire
        Cells(i, 5) = FileItem.ParentFolder
 
        i = i + 1
    Next FileItem
 
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder
 
End Sub

Bon après-midi à tous.

Raymond

07/07/2010, 18h30
patricktoulon

une idée

Tu pourrais peut être faire appel aux apis du wmplayer

Dans la faq tu as ça
Cherche bien
Dans les sources il y a même un player

Au plaisir

Bonsoir tous le monde, forum

Bonsoir Patricktoulon

Merci pour ta réponse, c'est sympa, tu vois ca fait 3 jours que je suis dessus, j'ai trouver sur le net les deux codes ci-dessous, mais je n'arrive pas a incorporer le chainon manquant au code d'origine afin d'obtenir le résultat souhaiter.
et je ne suis pas très fort du tout en vba

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub PropriétésFichiersAVI()
''http://www.microsoft.com/resources/documentation/windows/2000/server/scriptguide/en-us/sas_fil_lunl.mspx
''necessite d'activer reference Microsoft Shell Controls and Automation
Dim objShell As Object, strFileName As Object
Dim objFolder As Folder
Dim Resultat As String
Dim i As Byte
 
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace("E:\videos") 'adapter le chemin
 
'boucle sur les fichiers "avi" du répertoire
For Each strFileName In objFolder.Items
 
'attention à l'écriture de ".avi" : sensible aux majuscules et minuscules
 
If Right(objFolder.GetDetailsOf(strFileName, 0), 4) = ".avi" Then _
 
MsgBox objFolder.GetDetailsOf(strFileName, 0) & vbLf & objFolder.GetDetailsOf(strFileName, 21)
 
Next
End Sub
'-----------------------
 
Dim arrHeaders(35)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace("E:\Videos")
For i = 0 To 34
 arrHeaders(i) = objFolder.GetDetailsOf(objFolder.Items, i)
Next
For Each strFileName In objFolder.Items
 For i = 0 To 34
 Wscript.Echo i & vbTab & arrHeaders(i) _
 & ": " & objFolder.GetDetailsOf(strFileName, i)
 Next
Next

Un petit coup de main serai bienvenu, merci

au plaisir de relire et bonne soirée a tous

Merci patrick

Raymond

07/07/2010, 19h57
patricktoulon

re

je vais examiner ca en detail

deja a premiere vu il manque des variable declarée en debut de sub

mais je vais voir ca

au plaisir
07/07/2010, 20h07
eliot.raymond

Bonsoir a tous

Bonsoir Patrick

je te remercie pour ton coup de main j'apprécie car je ne pensait pas que c'était dur d'afficher la durée d'une video, la moi je nage comme une clé a molette,hihihi

bonne soirée a toi bon app et merci

Raymond
16/07/2010, 16h39
patricktoulon

re voila un truc muche a moi

bonjour raymond

tien regarde ce petit bricolage
j'oubliais ca marche pour tout les fichier media que le windowmediaplayer est cappable de lire
au plaisir
16/07/2010, 18h58
eliot.raymond

Bonsoir a tous le monde, forum bonsoir

Bonsoir Patricktoulon

Merci beaucoup pour ton code et ca marche presque hihihi

(1) sur une longue liste de films l'affichage est ralenti

(2) quand un film est blanc (pas de durée) il reste dessus très longtemps et de plus en général le traitement pour la durée est très long.

Voila sinon belles couleurs, mais ca marche et ca permets également de comprendre pas mal de choses.

Encore merci Patrick, je vais essayer d'améliorer.

je te souhaite un bon W-end et une bonne soirée

Raymond
16/07/2010, 19h02
patricktoulon

re

oui efectivement sur une longue liste ca ralenti vachement

mais c'etait avant tout pedagogique pour que tu comprenne le procedé

au plaisir