Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Michel Pierron
Bonjour Arthus;
Sub FavoritesFolderSave() Dim FavoritesFolder As String FavoritesFolder = CreateObject("WScript.Shell") _ .SpecialFolders("Favorites") Application.ScreenUpdating = False Workbooks.Add Call FilesInFolder(FavoritesFolder, 0, True) End Sub
Private Sub FilesInFolder(sFolderName As String _ , Optional Rw As Long = 0 _ , Optional SubDirs As Boolean = True) Dim FSO As Object, SourceFolder As Object Dim FileItem As Object, SubFolder As Object Dim FileType As String, n As String Set FSO = CreateObject("Scripting.FileSystemObject") Set SourceFolder = FSO.GetFolder(sFolderName) Rw = Rw + 1 Cells(Rw, 1) = sFolderName Cells(Rw, 1).Font.Bold = True For Each FileItem In SourceFolder.Files Application.StatusBar = SourceFolder & FileItem.Name If InStr(1, FileItem.Type, "Internet", 1) Then Rw = Rw + 1 Cells(Rw, 2) = FileItem.Name Rw = Rw + 1 n = ReadFile(FileItem.Path) ActiveSheet.Hyperlinks.Add _ Cells(Rw, 3), n, , n, n End If Next FileItem If SubDirs Then For Each SubFolder In SourceFolder.SubFolders Rw = Rw + 1 Call FilesInFolder(SubFolder.Path, Rw, True) Next SubFolder End If Application.StatusBar = False Columns("A:B").ColumnWidth = 1 Set FileItem = Nothing Set SubFolder = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub
Private Function ReadFile(FilePath) As String On Error Resume Next ReadFile = CreateObject("Wscript.Shell") _ .CreateShortcut(FilePath).TargetPath End Function
MP
"Arthus" <arthus(enlever)@free.fr> a écrit dans le message de news: 42995717$0$848$
Bonjour, Je seche:comment recuperer les liens "Mes favoris" dans un fichier excel Merci d'avance Arthus
Bonjour Arthus;
Sub FavoritesFolderSave()
Dim FavoritesFolder As String
FavoritesFolder = CreateObject("WScript.Shell") _
.SpecialFolders("Favorites")
Application.ScreenUpdating = False
Workbooks.Add
Call FilesInFolder(FavoritesFolder, 0, True)
End Sub
Private Sub FilesInFolder(sFolderName As String _
, Optional Rw As Long = 0 _
, Optional SubDirs As Boolean = True)
Dim FSO As Object, SourceFolder As Object
Dim FileItem As Object, SubFolder As Object
Dim FileType As String, n As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(sFolderName)
Rw = Rw + 1
Cells(Rw, 1) = sFolderName
Cells(Rw, 1).Font.Bold = True
For Each FileItem In SourceFolder.Files
Application.StatusBar = SourceFolder & FileItem.Name
If InStr(1, FileItem.Type, "Internet", 1) Then
Rw = Rw + 1
Cells(Rw, 2) = FileItem.Name
Rw = Rw + 1
n = ReadFile(FileItem.Path)
ActiveSheet.Hyperlinks.Add _
Cells(Rw, 3), n, , n, n
End If
Next FileItem
If SubDirs Then
For Each SubFolder In SourceFolder.SubFolders
Rw = Rw + 1
Call FilesInFolder(SubFolder.Path, Rw, True)
Next SubFolder
End If
Application.StatusBar = False
Columns("A:B").ColumnWidth = 1
Set FileItem = Nothing
Set SubFolder = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Private Function ReadFile(FilePath) As String
On Error Resume Next
ReadFile = CreateObject("Wscript.Shell") _
.CreateShortcut(FilePath).TargetPath
End Function
MP
"Arthus" <arthus(enlever)@free.fr> a écrit dans le message de news:
42995717$0$848$8fcfb975@news.wanadoo.fr...
Bonjour,
Je seche:comment recuperer les liens "Mes favoris" dans un fichier excel
Merci d'avance
Arthus
Sub FavoritesFolderSave() Dim FavoritesFolder As String FavoritesFolder = CreateObject("WScript.Shell") _ .SpecialFolders("Favorites") Application.ScreenUpdating = False Workbooks.Add Call FilesInFolder(FavoritesFolder, 0, True) End Sub
Private Sub FilesInFolder(sFolderName As String _ , Optional Rw As Long = 0 _ , Optional SubDirs As Boolean = True) Dim FSO As Object, SourceFolder As Object Dim FileItem As Object, SubFolder As Object Dim FileType As String, n As String Set FSO = CreateObject("Scripting.FileSystemObject") Set SourceFolder = FSO.GetFolder(sFolderName) Rw = Rw + 1 Cells(Rw, 1) = sFolderName Cells(Rw, 1).Font.Bold = True For Each FileItem In SourceFolder.Files Application.StatusBar = SourceFolder & FileItem.Name If InStr(1, FileItem.Type, "Internet", 1) Then Rw = Rw + 1 Cells(Rw, 2) = FileItem.Name Rw = Rw + 1 n = ReadFile(FileItem.Path) ActiveSheet.Hyperlinks.Add _ Cells(Rw, 3), n, , n, n End If Next FileItem If SubDirs Then For Each SubFolder In SourceFolder.SubFolders Rw = Rw + 1 Call FilesInFolder(SubFolder.Path, Rw, True) Next SubFolder End If Application.StatusBar = False Columns("A:B").ColumnWidth = 1 Set FileItem = Nothing Set SubFolder = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub
Private Function ReadFile(FilePath) As String On Error Resume Next ReadFile = CreateObject("Wscript.Shell") _ .CreateShortcut(FilePath).TargetPath End Function
MP
"Arthus" <arthus(enlever)@free.fr> a écrit dans le message de news: 42995717$0$848$
Bonjour, Je seche:comment recuperer les liens "Mes favoris" dans un fichier excel Merci d'avance Arthus
Arthus
Hyper Merci Arthus
"Michel Pierron" a écrit dans le message de news:
Bonjour Arthus;
Sub FavoritesFolderSave() Dim FavoritesFolder As String FavoritesFolder = CreateObject("WScript.Shell") _ .SpecialFolders("Favorites") Application.ScreenUpdating = False Workbooks.Add Call FilesInFolder(FavoritesFolder, 0, True) End Sub
Private Sub FilesInFolder(sFolderName As String _ , Optional Rw As Long = 0 _ , Optional SubDirs As Boolean = True) Dim FSO As Object, SourceFolder As Object Dim FileItem As Object, SubFolder As Object Dim FileType As String, n As String Set FSO = CreateObject("Scripting.FileSystemObject") Set SourceFolder = FSO.GetFolder(sFolderName) Rw = Rw + 1 Cells(Rw, 1) = sFolderName Cells(Rw, 1).Font.Bold = True For Each FileItem In SourceFolder.Files Application.StatusBar = SourceFolder & FileItem.Name If InStr(1, FileItem.Type, "Internet", 1) Then Rw = Rw + 1 Cells(Rw, 2) = FileItem.Name Rw = Rw + 1 n = ReadFile(FileItem.Path) ActiveSheet.Hyperlinks.Add _ Cells(Rw, 3), n, , n, n End If Next FileItem If SubDirs Then For Each SubFolder In SourceFolder.SubFolders Rw = Rw + 1 Call FilesInFolder(SubFolder.Path, Rw, True) Next SubFolder End If Application.StatusBar = False Columns("A:B").ColumnWidth = 1 Set FileItem = Nothing Set SubFolder = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub
Private Function ReadFile(FilePath) As String On Error Resume Next ReadFile = CreateObject("Wscript.Shell") _ .CreateShortcut(FilePath).TargetPath End Function
MP
"Arthus" <arthus(enlever)@free.fr> a écrit dans le message de news: 42995717$0$848$
Bonjour, Je seche:comment recuperer les liens "Mes favoris" dans un fichier excel Merci d'avance Arthus
Hyper Merci
Arthus
"Michel Pierron" <michel.pierron@free.fr> a écrit dans le message de news:
eQUn5cCZFHA.3320@TK2MSFTNGP12.phx.gbl...
Bonjour Arthus;
Sub FavoritesFolderSave()
Dim FavoritesFolder As String
FavoritesFolder = CreateObject("WScript.Shell") _
.SpecialFolders("Favorites")
Application.ScreenUpdating = False
Workbooks.Add
Call FilesInFolder(FavoritesFolder, 0, True)
End Sub
Private Sub FilesInFolder(sFolderName As String _
, Optional Rw As Long = 0 _
, Optional SubDirs As Boolean = True)
Dim FSO As Object, SourceFolder As Object
Dim FileItem As Object, SubFolder As Object
Dim FileType As String, n As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(sFolderName)
Rw = Rw + 1
Cells(Rw, 1) = sFolderName
Cells(Rw, 1).Font.Bold = True
For Each FileItem In SourceFolder.Files
Application.StatusBar = SourceFolder & FileItem.Name
If InStr(1, FileItem.Type, "Internet", 1) Then
Rw = Rw + 1
Cells(Rw, 2) = FileItem.Name
Rw = Rw + 1
n = ReadFile(FileItem.Path)
ActiveSheet.Hyperlinks.Add _
Cells(Rw, 3), n, , n, n
End If
Next FileItem
If SubDirs Then
For Each SubFolder In SourceFolder.SubFolders
Rw = Rw + 1
Call FilesInFolder(SubFolder.Path, Rw, True)
Next SubFolder
End If
Application.StatusBar = False
Columns("A:B").ColumnWidth = 1
Set FileItem = Nothing
Set SubFolder = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Private Function ReadFile(FilePath) As String
On Error Resume Next
ReadFile = CreateObject("Wscript.Shell") _
.CreateShortcut(FilePath).TargetPath
End Function
MP
"Arthus" <arthus(enlever)@free.fr> a écrit dans le message de news:
42995717$0$848$8fcfb975@news.wanadoo.fr...
Bonjour,
Je seche:comment recuperer les liens "Mes favoris" dans un fichier excel
Merci d'avance
Arthus
Sub FavoritesFolderSave() Dim FavoritesFolder As String FavoritesFolder = CreateObject("WScript.Shell") _ .SpecialFolders("Favorites") Application.ScreenUpdating = False Workbooks.Add Call FilesInFolder(FavoritesFolder, 0, True) End Sub
Private Sub FilesInFolder(sFolderName As String _ , Optional Rw As Long = 0 _ , Optional SubDirs As Boolean = True) Dim FSO As Object, SourceFolder As Object Dim FileItem As Object, SubFolder As Object Dim FileType As String, n As String Set FSO = CreateObject("Scripting.FileSystemObject") Set SourceFolder = FSO.GetFolder(sFolderName) Rw = Rw + 1 Cells(Rw, 1) = sFolderName Cells(Rw, 1).Font.Bold = True For Each FileItem In SourceFolder.Files Application.StatusBar = SourceFolder & FileItem.Name If InStr(1, FileItem.Type, "Internet", 1) Then Rw = Rw + 1 Cells(Rw, 2) = FileItem.Name Rw = Rw + 1 n = ReadFile(FileItem.Path) ActiveSheet.Hyperlinks.Add _ Cells(Rw, 3), n, , n, n End If Next FileItem If SubDirs Then For Each SubFolder In SourceFolder.SubFolders Rw = Rw + 1 Call FilesInFolder(SubFolder.Path, Rw, True) Next SubFolder End If Application.StatusBar = False Columns("A:B").ColumnWidth = 1 Set FileItem = Nothing Set SubFolder = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub
Private Function ReadFile(FilePath) As String On Error Resume Next ReadFile = CreateObject("Wscript.Shell") _ .CreateShortcut(FilePath).TargetPath End Function
MP
"Arthus" <arthus(enlever)@free.fr> a écrit dans le message de news: 42995717$0$848$
Bonjour, Je seche:comment recuperer les liens "Mes favoris" dans un fichier excel Merci d'avance Arthus