Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11

Lister le contenu d'un repertoire... DocMarti Help

1 réponse
Avatar
BlackStorm
Salut a toi et merci pour ton aide, j'avais evoqué mon prbleme le 8.02.04:
Alors essaie-le comme ceci:
Je suis pas très doué, mais j'ai une question: ce que tu m'as indiqué
ci-dessous c'est bien une requete qui va de la marque 1 à la marque 2 ?
parce que j'arrive pas a faire tourner ca ?
'Marque1'
Option Explicit
Dim nbrFichier As Long

Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub RunShellExecute(Chemin)

ShellExecute 0&, vbNullString, Chemin, vbNullString, _
vbNullString, vbNormalFocus
End Sub

Private Sub CommandButton1_Click()
Dim strExtension As String

strExtension = ".txt .mdb .xls .doc .xls .pdf .ppm .eml "

strExtension = Trim(UCase(strExtension)) & " "

Call DirRep("c:\aa\", strExtension)

End Sub

Private Sub CommandButton2_Click()

Dim Chemin As String
Chemin = Trim(ActiveCell.Value)
If Chemin <> "" Then
Call RunShellExecute(Chemin)
End If
End Sub





Private Sub DirRep(NomRep As String, strExtention As String)
Dim Dossiers As New Collection
Dim NomFic As String
Dim i As Integer

If Right(NomRep, 1) <> "\" Then NomRep = NomRep & "\"
NomFic = Dir(NomRep & "*.*", vbNormal Or vbDirectory)
While NomFic <> ""
If (GetAttr(NomRep & NomFic) And vbDirectory) = vbDirectory Then
If (NomFic <> ".") And (NomFic <> "..") Then
Dossiers.Add NomRep & NomFic
End If
Else
Dim extension As String
If InStr(NomFic, ".") > 0 Then
extension = NomFic
While InStr(extension, ".")
extension = Mid(extension, InStr(extension, ".") + 1)
Wend
extension = "." & UCase(extension) & " "
If InStr(strExtention, extension) > 0 Then
nbrFichier = nbrFichier + 1
Sheets("Feuil1").Cells(nbrFichier, 1).Value = NomRep & NomFic
End If
End If
End If

NomFic = Dir
Wend

' Appel récursif de la même fonction pour traiter les sous-répertoires
While Dossiers.Count > 0
DirRep Dossiers(1), strExtention
Dossiers.Remove 1
Wend

End Sub
'Marque 2'

"BlackStorm" <BlackStorm@Hotmail.com> wrote in message
news:emw$y#W7DHA.360@TK2MSFTNGP12.phx.gbl...
> Merci,
>
> Mais... ca ne fonctionne pas j'ai une erreur de complilation :
> Private Declare Function GetDesktopWindow Lib "user32" () As Long
>
> merci en tout cas pour ton aide mais si tu pouvais encore m'aider la !?
> "docmarti" <docmarti@spam.net> a écrit dans le message de news:
> u4UMKIW7DHA.712@tk2msftngp13.phx.gbl...
> > Bonjour BlackStorm.
> >
> > Voici comment obtenir la liste des documents des types sélectionnés. Et
> > comment ouvrir le document dont le chemin se trouve dans la cellule
> > sélectionnée avec le programme approprié.
> >
> > Option Explicit
> > Dim nbrFichier As Long
> >
> > Private Declare Function GetDesktopWindow Lib "user32" () As Long
> >
> > Private Declare Function ShellExecute Lib "shell32.dll" _
> > Alias "ShellExecuteA" _
> > (ByVal hwnd As Long, ByVal lpOperation As String, _
> > ByVal lpFile As String, ByVal lpParameters As String, _
> > ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
> >
> > Private Const SW_SHOWNORMAL As Long = 1
> > Private Const SW_SHOWMAXIMIZED As Long = 3
> > Private Const SW_SHOWDEFAULT As Long = 10
> > Private Const SE_ERR_NOASSOC As Long = 31
> >
> > Private Sub CommandButton1_Click()
> > 'obtenir la liste des documents des types sélectionnés
> > Dim strExtension As String
> >
> > strExtension = ".txt .mdb .xls .doc .xls .pdf .ppm .eml "
> >
> > strExtension = Trim(UCase(strExtension)) & " "
> >
> > Call DirRep("c:\", strExtension)
> >
> > End Sub
> >
> > Private Sub CommandButton2_Click()
> > ' ouvrir le document dont le chemin se trouve dans la cellule
sélectionnée
> > avec le programme approprié.
> >
> > Dim Chemin As String
> > Chemin = Trim(ActiveCell.Value)
> > If Chemin <> "" Then
> > Call RunShellExecute(Chemin)
> > End If
> > End Sub
> >
> > Private Sub RunShellExecute(Chemin)
> > Dim hWndDesk As Long
> > Dim success As Long
> > Dim sfile As String
> > 'fichier à ouvrir, qu'importe le type:
> > sfile = Chemin
> >
> > hWndDesk = GetDesktopWindow()
> > success = ShellExecute(hWndDesk, "Open", _
> > sfile, 0&, 0&, SW_SHOWNORMAL)
> > End Sub
> >
> >
> >
> > Private Sub DirRep(NomRep As String, strExtention As String)
> > Dim Dossiers As New Collection
> > Dim NomFic As String
> > Dim i As Integer
> >
> > If Right(NomRep, 1) <> "\" Then NomRep = NomRep & "\"
> > NomFic = Dir(NomRep & "*.*", vbNormal Or vbDirectory)
> > While NomFic <> ""
> > If (GetAttr(NomRep & NomFic) And vbDirectory) = vbDirectory Then
> > If (NomFic <> ".") And (NomFic <> "..") Then
> > Dossiers.Add NomRep & NomFic
> > End If
> > Else
> > Dim extension As String
> > If InStr(NomFic, ".") > 0 Then
> > extension = NomFic
> > While InStr(extension, ".")
> > extension = Mid(extension, InStr(extension, ".") + 1)
> > Wend
> > extension = "." & UCase(extension) & " "
> > If InStr(strExtention, extension) > 0 Then
> > nbrFichier = nbrFichier + 1
> > Sheets("Feuil1").Cells(nbrFichier, 1).Value = NomRep &
NomFic
> > End If
> > End If
> > End If
> >
> > NomFic = Dir
> > Wend
> >
> > ' Appel récursif de la même fonction pour traiter les
sous-répertoires
> > While Dossiers.Count > 0
> > DirRep Dossiers(1), strExtention
> > Dossiers.Remove 1
> > Wend
> >
> > End Sub
> >
> >
> > "BlackStorm" <BlackStorm@Hotmail.com> wrote in message
> > news:#rV8KtR7DHA.488@TK2MSFTNGP12.phx.gbl...
> > > Bonjour,
> > >
> > > Je travaille sur plusieurs gros disques reseaux sur lesquels je gére
de
> la
> > > doc (fichier excel, word, txt, eml.....). J'essai de regrouper par
theme
> > les
> > > differents documents dans différents repertoires sur 2 disques
> principaux
> > > F:\ et G:\.
> > >
> > > Or mes collégues enregistrent des docs un peu partout, créeant des
> > > repertoires à la volée.(Mon admin refuse de limiter les la creation de
> > > repertoire et de doc).
> > >
> > > Je desirerai
> > > 1er)sous Excel, repertorier l'enesmble des documents contenu sur les
> > > disques, par repertoire , les archiver sur une feuille.
> > > 2eme) Faire une recherche sur un document et avoir automatiquement le
> lien
> > > pour l'ouverture. Cad, aue j'aurai dans une feuille contenant une
liste
> de
> > > lien
> > > f:\Espace Document Technique\cahier des charges\gestion solution.doc
> > > je voudrais que ce lien puisse etre activé et que le document soit
> ouvert
> > > directement par l'application necessaire. Et cela pour l'ensemble des
> > > documents (doc, xls, pdf, ppm,eml....)
> >
> > Pour ouvrir un document avec l'application nécessaire:
> > Option Explicit
> >
> > Private Declare Function GetDesktopWindow Lib "user32" () As Long
> >
> > Private Declare Function ShellExecute Lib "shell32.dll" _
> > Alias "ShellExecuteA" _
> > (ByVal hwnd As Long, ByVal lpOperation As String, _
> > ByVal lpFile As String, ByVal lpParameters As String, _
> > ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
> >
> > Private Const SW_SHOWNORMAL As Long = 1
> > Private Const SW_SHOWMAXIMIZED As Long = 3
> > Private Const SW_SHOWDEFAULT As Long = 10
> > Private Const SE_ERR_NOASSOC As Long = 31
> >
> > Public Sub RunShellExecute(path)
> > Dim hWndDesk As Long
> > Dim success As Long
> > Dim sfile As String
> > 'fichier à ouvrir, qu'importe le type:
> > sfile = path
> >
> > hWndDesk = GetDesktopWindow()
> > success = ShellExecute(hWndDesk, "Open", _
> > sfile, 0&, 0&, SW_SHOWNORMAL)
> > End Sub
> >
> > > Apres quoi je ferai un rapport d'impression pour que chacun puisse
> savoir
> > ou
> > > son stocker les documents necessaires soit un volume de plusieurs
> milliers
> > !
> > > Si vous avez une solution, je suis preneur !
> > >
> > > Merci d'avance !
> > >
> > >
> > >
> > >
> >
> >
>
>

1 réponse

Avatar
docmarti
Bonjour.
Voir ma réponse dans le fil original.