Sub Test()
    MsgBox FichierExiste("C:\Documents and Settings\dossier\dataBase.mdb")
End Sub
 
 
Function FichierExiste(NomFichier As String) As Boolean
    FichierExiste = Dir(NomFichier) <> "" And NomFichier <> ""
End Function

Sub Test()
    MsgBox DossierExiste("C:\Documents and Settings\Nom Dossier")
End Sub
 
 
Function DossierExiste(NomDossier As String) As Boolean
    DossierExiste = Dir(NomDossier, vbSystem + vbDirectory + vbHidden) <> ""
End Function

Sub afficherRepertoireParent()
    If ThisWorkbook.Path = "" Then
        MsgBox "Est-ce que votre classeur est sauvegardé ?"
        Exit Sub
    End If
 
    ChDir (ThisWorkbook.Path)
    ChDir ".."
    MsgBox CurDir
End Sub

Sub afficherRepertoireParent_V02()
    Dim Chemin As String
 
    If ThisWorkbook.Path = "" Then
        MsgBox "Est-ce que votre classeur est sauvegardé ?"
        Exit Sub
    End If
 
    ChDir (ThisWorkbook.Path)
    ChDir ".."
    Chemin = Left(CurDir, InStrRev(CurDir, "\") - 1)
    MsgBox Chemin
End Sub

Sub Test()
    CreationRepertoire "C:\Documents and Settings\dossier", "Archives"
End Sub
 
 
Sub CreationRepertoire(DossierParent As String, NomRep As String)
    Dim Chemin As String
 
    'Vérifie si le répertoire existe.
    If Dir(DossierParent, vbDirectory + vbHidden) <> "" Then
        'Vérifie que le dossier à créer n'existe pas déjà dans le répertoire
        If Dir(DossierParent & "\" & NomRep, vbDirectory + vbHidden) = "" Then _
            MkDir DossierParent & "\" & NomRep
    End If
End Sub

Sub repertoireExplorateur_V1()
    Dim Chemin As String
 
    Chemin = "C:\Documents and Settings\dossier"
    Shell "C:\windows\explorer.exe " & Chemin, vbMaximizedFocus
End Sub

Sub repertoireExplorateur_V2()
    Dim Chemin As String
 
    Chemin = "C:\Documents and Settings\dossier"
    ThisWorkbook.FollowHyperlink Chemin
End Sub

Sub repertoireExplorateur_V3()
    Dim Chemin As String
    Dim IE As Object
 
    Chemin = "C:\Documents and Settings\dossier"
 
    Set IE = CreateObject("internetExplorer.Application")
    IE.Navigate Chemin
    IE.Visible = True
End Sub

Sub repertoireExplorateur_V4()
    'Nécessite d'activer la référence "Microsoft Shell Controls and Automation"
    Dim objShell As Shell
    Dim Chemin As String
 
    Chemin = "C:\Documents and Settings\dossier"
 
    Set objShell = New Shell
    objShell.Explore (Chemin)
End Sub

Sub BoucleFichiers()
    Dim Chemin As String, Fichier As String
 
    'Définit le répertoire contenant les fichiers
    Chemin = "C:\dossier\"
 
    'Boucle sur tous les fichiers xls du répertoire.
    Fichier = Dir(Chemin & "*.xls")
    'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers :
    'Fichier = Dir(Chemin & "*.*")
 
    Do While Len(Fichier) > 0
        'écrit le résultat dans la fenêtre d'exécution (Ctrl+G).
        Debug.Print Chemin & Fichier
        Fichier = Dir()
    Loop
End Sub

Sub Test_V1()
    MsgBox NombreFichiers("C:\dossier")
End Sub
 
 
Function NombreFichiers(ByVal Dossier As String) As Long
    Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    NombreFichiers = FSO.GetFolder(Dossier).Files.Count
 
    Set FSO = Nothing
End Function

Sub Test_V2()
    'Compte tous les fichiers
    MsgBox NbFich("C:\dossier", "*")
    'Compte tous les fichiers type .txt et .xls    
    MsgBox NbFich("C:\dossier", "txt", "xls")
End Sub
 
Function NbFich(Chemin As String, ParamArray Termin() As Variant) As Long
'Auteur: Random
Dim Fichier As String
Dim Extension As Variant
Dim Compteur As Long
 
For Each Extension In Termin
   Fichier = Dir(Chemin & "\*." & Extension)
   Do Until Fichier = ""
   Compteur = Compteur + 1
   Fichier = Dir
   Loop
Next Extension
 
NbFich = Compteur
End Function

Sub RenommeFichier()
    Dim AncienNom As String, NouveauNom As String
 
    AncienNom = "C:\Documents and Settings\dossier\NomInitial.pdf"
    NouveauNom = "C:\Documents and Settings\dossier\Nom modifié.pdf"
 
    'Vérifie si le fichier à renommer existe.
    If Dir(AncienNom) = "" Then Exit Sub
    'Renomme le fichier
    Name AncienNom As NouveauNom
End Sub

Option Explicit
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
 
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
 
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
 
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
    (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal _
    dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes _
    As Long, ByVal hTemplateFile As Long) As Long
 
Private Declare Function SetFileTime Lib "kernel32" (ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
 
Private Declare Function SystemTimeToFileTime Lib "kernel32" _
    (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
 
Private Declare Function CloseHandle Lib "kernel32" _
    (ByVal hObject As Long) As Long
 
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" _
    (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
 
 
 
Sub Test()
    'KPD-Team 1998
    'URL: http://www.allapi.net/
    'KPDTeam@Allapi.net
    '
    'Adapté en VBA le 08/07/2006
    '
 
    Dim m_Date As Date
    Dim lngHandle As Long
    Dim udtFileTime As FILETIME
    Dim udtLocalTime As FILETIME
    Dim udtSystemTime As SYSTEMTIME
    Dim Fichier As String
 
    Fichier = "C:\dossier\nom fichier.txt"
 
    'Le fichier va prendre la date du jour (Now)
    m_Date = Format(Now, "DD-MM-YY")
 
    udtSystemTime.wYear = Year(m_Date)
    udtSystemTime.wMonth = Month(m_Date)
    udtSystemTime.wDay = Day(m_Date)
    udtSystemTime.wDayOfWeek = Weekday(m_Date) - 1
    udtSystemTime.wHour = Hour(m_Date)
    udtSystemTime.wSecond = Second(m_Date)
    udtSystemTime.wMilliseconds = 0
 
    ' convertit l'heure systême en heure locale
    SystemTimeToFileTime udtSystemTime, udtLocalTime
    ' convertit l'heure locale en GMT
    LocalFileTimeToFileTime udtLocalTime, udtFileTime
 
    lngHandle = CreateFile(Fichier, GENERIC_WRITE, _
        FILE_SHARE_READ Or FILE_SHARE_WRITE, _
        ByVal 0&, OPEN_EXISTING, 0, 0)
    ' modifie les propriétés date/heure du fichier
    SetFileTime lngHandle, udtFileTime, udtFileTime, udtFileTime
    ' fermeture
    CloseHandle lngHandle
End Sub

Option Explicit
 
Private Type StructureFichier
     hwnd As Long
     wFunc As Long
     pFrom As String
     pTo As String
     fFlags As Integer
     fAnyOperationsAborted As Boolean
     hNameMappings As Long
     lpszProgressTitle As String
End Type
 
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
    "SHFileOperationA" (lpFileOp As StructureFichier) As Long
 
 
Private Const FO_DELETE = &H3
'Avec message d'alerte
Private Const FOF_ALLOWUNDO = &H40
'Sans message d'alerte
Private Const FOF_NOCONFIRMATION = &H10
 
 
Sub Test()
    EnvoiCorbeille "C:\dossier\NomFichier.xls"
End Sub
 
 
Function EnvoiCorbeille(Fichier As String) As Boolean
    Dim Cible As StructureFichier
    Dim lReturn As Long
 
    'Vérifie si le fichier existe.
    If Dir(Fichier) = "" Then Exit Function
 
    With Cible
        .wFunc = FO_DELETE
        .pFrom = Fichier
        .fFlags = FOF_ALLOWUNDO
        'Pour ne pas afficher le message d'alerte :
        '.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
    End With
 
    'Envoie le fichier dans la corbeille
    lReturn = SHFileOperation(Cible)
End Function

Sub CheminRepertoiresSpeciaux()
    'Testé avec Excel 2002 & WinXp
    Const Cible = &H5 'Mes Documents
    Dim objShell As Object
    Dim objFolder As Object, objFolderItem As Object
 
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.NameSpace(Cible)
    Set objFolderItem = objFolder.Self
 
    MsgBox objFolderItem.Path
 
    'La liste des constantes pour afficher le chemin des autres dossiers spéciaux de Windows
    '(Const Cible = &H5 'Mes Documents )
 
    '&H5  = My Documents
    '&HC  = (Virtual) \My Documents\
    '&H27 = \My Documents\My Pictures
    '&H2E = \Documents
    '&HD  = \My Documents\My Music
    '&HE   = \My Documents\My Video
    '&H0  = Virtual Desktop
    '&H1  = Virtual Internet Explorer (icon on desktop)
    '&H2  = Start Menu\Programs
    '&H3  = Virtual My Computer\Control Panel
    '&H4  = Virtual My Computer\Printers
    '&H6  = \Favorites
    '&H7  = Start Menu\Programs\Startup
    '&H8  = \Recent
    '&H9  = \SendTo
    '&HA  = Virtual \Recycle Bin
    '&HB  = \Start Menu
    '&H10 = \Desktop
    '&H11 = Virtual My Computer
    '&H12 = Virtual  Network Neighborhood
    '&H13 = \nethood (may dupe My Network Places)
    '&H14 = Virtual windows\fonts
    '&H15 = \templates
    '&H16 = \Start Menu
    '&H17 = \Programs
    '&H18 = \Startup
    '&H19 = \Desktop
    '&H1A = \Application Data
    '&H1B = \PrintHood
    '&H1C = \Local Settings\Applicaiton Data (non roaming)
    '&H1D = nonlocalized startup program group
    '&H1E = (NT) nonlocalized Startup group for all NT users
    '&H1F = (NT) all user's favorite items
    '&H20 = temporary Internet files
    '&H21 = (NT) Internet cookies
    '&H22 = (NT) Internet history items
    '&H23 = \Application Data
    '&H24 = Windows directory or SYSROOT
    '&H25 = GetSystemDirectory()
    '&H26 = \Program Files
    '&H28 = \
    '&H29 = x86 system directory on RISC
    '&H2A = x86 Program Files folder on RISC
    '&H2B = \Program Files\Common
    '&H2C = x86 Program Files Common folder on RISC
    '&H2D = \Templates
    '&H2F = \Start Menu\Programs\Administrative Tools
    '&H30 = \Start Menu\Programs\Administrative Tools
    '&H31 = Virtual Network and dial-up connections folder
    '&H35 = My Music folder for all users
    '&H36 = My Pictures folder for all users
    '&H37 = My Video folder for all users
    '&H38 = System resource directory
    '&H39 = Localized resource directory
    '&H3A = Links to OEM specific apps for all users
    '&H3B = \Local Settings\Application Data\Microsoft\CD Burning
    '&H3D = Virtual Computers Near Me folder
 
End Sub

Sub tailleElementsCorbeille()
    Dim objShell As Object, objFolder As Object, colItems As Object, objItem As Object
    Dim tailleGDO As String
    Dim Taille As Long, Resultat As Long
 
    'Corbeille
    Const Cible = &HA&
 
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(Cible)
    Set colItems = objFolder.Items
 
    'Boucle sur les éléments de la corbeille
    For Each objItem In colItems
        '3 = taille fichier
        tailleGDO = objFolder.GetDetailsOf(objItem, 3)
        Resultat = Resultat + CLng(Val(tailleGDO))
    Next
 
    MsgBox Resultat & " kb"
End Sub

'*********************
'Sources :
'https://support.microsoft.com/fr-fr/help/466935
'https://support.microsoft.com/fr-fr/help/160042
'https://vb.developpez.com/faq/?page=Fichiers#num_version
'
'adapté pour utilisation en VBA Excel
'*********************
 
Option Explicit
 
'Renvoie des informations sur la version, pour le fichier spécifié.
'lptstrFilename: adresse du nom de fichier
'dwHandle: handle d'information sur la version
'dwLen: taille du buffer contenant l'information
'lpData: adresse du premier octet du buffer contenant l'information
Private Declare Function GetFileVersionInfo Lib "Version.dll" Alias _
"GetFileVersionInfoA" (ByVal lptstrFilename As String, ByVal dwHandle As Long, _
ByVal dwLen As Long, lpData As Any) As Long
 
'La fonction GetFileVersionInfoSize détermine si les informations sur la
'version existent. Si c'est le cas, cette fonction retourne la taille du
'buffer contenant l'information et le handle d'information que l'on
'passera à L'API GetFileVersionInfo. Cette dernière permet de récupérer
'les informations sur la version.
'lptstrFilename: adresse du nom de fichier
'lpdwHandle: adresse du handle d'information sur la version
Private Declare Function _
GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, lpdwHandle As Long) As Long
 
'La fonction VerQueryValue retourne la partie d'information sur la version :
'pBlock: adresse du premier octet du buffer contenant l'information
'lpSubBlock: adresse de la partie de l'information qui nous intéresse
'lplpBuffer: adresse du buffer contenant la valeur demandée
'puLen: adresse de la taille du buffer contenant la valeur demandée
Private Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" _
(pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Any, puLen As Long) As Long
 
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, _
ByVal Source As Long, ByVal Length As Long)
 
'Copie une chaîne de caractères dans une autre
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _
(ByVal lpString1 As String, ByVal lpString2 As Long) As Long
 
'Renvoie l'adresse de l'executable auquel le fichier est associé
Public Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, _
ByVal lpdirectory As String, ByVal lpResult As String) As Long
 
Public Const MAX_FILENAME_LEN = 256
 
 
Public Function DescriptionAppli(ByVal Cible As String, _
    ByVal TypeInfo As String) As String
 
    Dim Buffer As String, Lang_Charset_String As String
    Dim Rc As Long, HexNumber As Long, P As Long
    Dim strVersionInfo As String, strTemp As String
    Dim BufferLen As Long, Dummy As Long
    Dim sBuffer() As Byte
    Dim ByteBuffer(255) As Byte
 
    strVersionInfo = TypeInfo
 
    'Vérifie si les informations sur la version existent.
    BufferLen = GetFileVersionInfoSize(Cible, Dummy)
    If BufferLen < 1 Then Exit Function
 
    ReDim sBuffer(BufferLen)
    Rc = GetFileVersionInfo(Cible, 0&, BufferLen, sBuffer(0))
    If Rc = 0 Then
        DescriptionAppli = False
        Exit Function
    End If
 
    '"\VarFileInfo\Translation" permet de récupérer la langue utilisée et
    'le type de caractère :
    'Par exemple, on peut récupérer la valeur 040C1200 où 040C identifie la
    'langue française et 1200 identifie le jeu de caractères Unicode
    '(Les valeurs des identifiants de langue et de jeu de caractères sont
    'données dans l'aide WIN SDK 32 HELP pour la structure VERSIONINFO).
    Rc = _
    VerQueryValue(sBuffer(0), "\VarFileInfo\Translation", P, BufferLen)
 
    If Rc = 0 Then Exit Function
 
    MoveMemory ByteBuffer(0), P, BufferLen
 
    HexNumber = ByteBuffer(2) + ByteBuffer(3) * &H100 + ByteBuffer(0) * _
        &H10000 + ByteBuffer(1) * &H1000000
 
    Lang_Charset_String = Hex(HexNumber)
 
    Do While Len(Lang_Charset_String) < 8
        Lang_Charset_String = "0" & Lang_Charset_String
    Loop
 
    Buffer = String(255, 0)
    strTemp = "\StringFileInfo\" & Lang_Charset_String & "\" & strVersionInfo
    Rc = VerQueryValue(sBuffer(0), strTemp, P, BufferLen)
 
    If Rc = 0 Then Exit Function
 
    lstrcpy Buffer, P
    Buffer = Mid$(Buffer, 1, InStr(Buffer, Chr(0)) - 1)
 
    DescriptionAppli = Buffer
End Function
 
 
'Permet de retrouver l'executable du fichier spécifié.
Function FindExecutable(s As String) As String
    Dim i As Integer
    Dim S2 As String
 
    S2 = String(MAX_FILENAME_LEN, 32) & Chr$(0)
    i = FindExecutableA(s & Chr$(0), vbNullString, S2)
 
    If i > 32 Then
        FindExecutable = Left$(S2, InStr(S2, Chr$(0)) - 1)
        Else
        FindExecutable = ""
    End If
End Function
 
 
Sub AfficherInformationsApplication()
    Dim Resultat As String, MonAppli As String, LeFichier As String
    Dim X As Variant
    Dim Tableau As Variant
    Dim i As Byte
 
    'Définit les types d'informatins à récupérer
    Tableau = Array("Name", "comments ", "CompanyName", "FileDescription", _
        "FileVersion", "InternalName", "LegalCopyright", "legalTrademarks", _
        "privateBuild", "OriginalFileName", "ProductName", _
        "productVersionNum", "ProductVersion")
 
    'Affiche un boîte de dialogue pour sélectionner un fichier sur le PC
    X = Application.GetOpenFilename
    'On sort si aucun fichier n'est sélectionné ou si vous avez appuyé
    'sur le bouton "Annuler".
    If X = False Then Exit Sub
 
    LeFichier = X
    'Recherche l'executable associé au fichier sélectionné
    MonAppli = FindExecutable(LeFichier)
 
    'boucle sur les infos à récupérer
    For i = 0 To 12
        Resultat = Resultat & Tableau(i) & " :  " & _
            DescriptionAppli(MonAppli, Tableau(i)) & vbLf
    Next i
 
    'Affiche le resultat de la procedure
    MsgBox Resultat, , "Informations : " & MonAppli
End Sub

Option Explicit
 
 
Sub triDecroissant_Fichiers_DateDreation()
    Dim Fichier As String, Chemin As String
    '
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    '
    Dim Fso As Scripting.FileSystemObject
    Dim FileItem As Scripting.File
    Dim Tableau()
    Dim Plage As Range
    Dim m As Integer, i As Integer
    Dim z As Byte, Valeur As Byte
    Dim Cible As Variant
 
    '---liste les fichiers du répertoire ---
    Chemin = "C:\Documents and Settings\dossier"
    Fichier = Dir(Chemin & "\*.*")
    'pour filtrer sur un type de fichiers (par exemple xls)
    'Fichier = Dir(Chemin & "\*.xls")
 
    'Boucle sur les fichiers
    Do
 
        m = m + 1
        ReDim Preserve Tableau(1 To 2, 1 To m)
        Tableau(1, m) = Fichier
 
        Set Fso = CreateObject("Scripting.FileSystemObject")
        Set FileItem = Fso.GetFile(Chemin & "\" & Fichier)
 
        'Récupère la date de création
        Tableau(2, m) = Left(FileItem.DateCreated, 10)
        'Pour récupérer la date de dernière modification
        'Tableau(2, m) = Left(FileItem.DateLastModified, 10)
        'Pour récupérer la taille du fichier
        'Tableau(2, m) = Left(FileItem.Size, 10)
 
        Fichier = Dir
    Loop Until Fichier = ""
 
 
    '---Trie les fichiers par ordre décroissant de création ---
    Do
        Valeur = 0
        For i = 1 To m - 1
            If CDate(Tableau(2, i)) < CDate(Tableau(2, i + 1)) Then
                For z = 1 To 2
                    Cible = Tableau(z, i)
                    Tableau(z, i) = Tableau(z, i + 1)
                    Tableau(z, i + 1) = Cible
                Next z
 
                Valeur = 1
            End If
        Next i
    Loop While Valeur = 1
 
 
    '--- Transfère les données dans la feuille de calcul ---
    Set Plage = Worksheets("Feuil2").Range("A1")
    Set Plage = Plage.Resize(UBound(Tableau(), 2), UBound(Tableau()))
    Plage = Application.Transpose(Tableau())
 
End Sub

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 qu 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

Sub CopierFichier()
    'Copie le fichier dans un autre dossier :
    'syntaxe : FileCopy "source", "destination"
    FileCopy "C:\dossier\general\excel\Classeur.xls", "D:\Classeur.xls"
End Sub

Sub listeConnexionsReseau_Et_CheminsUNC()
    Dim oNetWork As Object, objDisques As Object
    Dim i As Integer
 
    ' l'objet WScript.Network permet de récupérer des informations
    ' au sujet des connexions réseau.
    Set oNetWork = CreateObject("WScript.Network")
    'Renvoie la collection de lecteurs réseaux
    Set objDisques = oNetWork.EnumNetworkDrives
 
    For i = 0 To objDisques.Count - 1 Step 2
        'Ecrit le résultat dans la fenêtre d'exécution (Ctrl+G)
        Debug.Print objDisques.Item(i) & vbTab & objDisques.Item(i + 1)
    Next
End Sub

Sub creerRaccourciBureau()
    'Nécessite d'activer la référence "Windows Script Host Object Model"
    Dim xShell As IWshRuntimeLibrary.wshShell
    Dim Raccourci As IWshRuntimeLibrary.wshShortcut
    Dim dirBureau As String
 
    Set xShell = CreateObject("WScript.Shell")
    'Récupère le chemin du bureau
    dirBureau = xShell.specialFolders("Desktop")
    'Crée le raccourci
    Set Raccourci = xShell.createShortcut(dirBureau & "\monFichier.lnk")
    'Attribue le chemin du classeur contenant cette macro
    Raccourci.targetPath = ThisWorkbook.FullName
    Raccourci.windowStyle = 1
    'attribue un icône
    'Raccourci.iconLocation = "C:\BOOK\GUIDE.ICO"
    Raccourci.Save
End Sub

Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, _
    ByVal pv As String)
 
Sub viderMenuDocumentsRecents()
    'C:\Documents and Settings\nom_utilisateur\Recent
    SHAddToRecentDocs 2, vbNullString
End Sub

Option Explicit
 
Dim tvn As Node
 
 
Private Sub CommandButton1_Click()
    Dim monrep As String
 
    TreeView1.Nodes.Clear
    ' on définit ici le répertoire à "déployer"
    monrep = "C:\Documents and Settings\mimi\dossier\"
 
    If Right$(monrep, 1) <> "\" Then monrep = monrep$ + "\"
 
    Set tvn = TreeView1.Nodes.Add(, vbNullString, monrep, monrep)
    deployons monrep
End Sub
 
 
Sub deployons(ByVal chemin As String)
  Dim nomfic As String, numfic As Integer, tp As String, i As Integer
 
  If Right$(chemin, 1) <> "\" Then chemin = chemin & "\"
  nomfic = Dir$(chemin, vbDirectory)
  numfic = 1
 
  Do While nomfic <> ""
    If nomfic <> "." And nomfic <> ".." Then
      tp = chemin & nomfic
      If GetAttr(tp) And vbDirectory Then
        Set tvn = TreeView1.Nodes.Add(chemin, tvwChild, tp + "\", nomfic)
        deployons tp
        nomfic = Dir$(chemin, vbDirectory)
        For i = 2 To numfic
          nomfic = Dir$
        Next
      End If
    End If
    nomfic = Dir$: numfic = numfic + 1
   Loop
End Sub
 
 
'Récupère le chemin du dossier lorsque vous double cliquez sur l'élément
Private Sub TreeView1_DblClick()
   MsgBox TreeView1.SelectedItem.FullPath
End Sub

Sub informationsRaccourci()
    'Nécessite d'activer les références
        'Microsoft Shell Controls and Automation
        'Microsoft Scripting Runtime
 
    'le répertoire contenant les raccourcis
    Const Cible = "C:\Documents and Settings\mimi\dossier"
 
    Dim objShell As Shell32.Shell
    Dim objFolder As Shell32.Folder
    Dim colItems As Shell32.FolderItems
    Dim objItem As Shell32.FolderItem
    Dim i As Integer
    Dim Fso As Scripting.FileSystemObject
    Dim FileItem As Scripting.File
 
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(Cible)
    Set colItems = objFolder.Items
    Set Fso = CreateObject("Scripting.FileSystemObject")
 
    'Boucle sur les éléments u répertoire
    For Each objItem In colItems
        'S'il s'agit d'un raccourci :
        If objItem.IsLink Then
            i = i + 1
            'repertoire lien
            Cells(i, 1) = objItem.Path
            'cible du lien (repertoire et nom)
            Cells(i, 2) = objItem.GetLink.Path
            'Repertoire de la cible
            Cells(i, 3) = objFolder.GetDetailsOf(objItem, 14)
 
            If Fso.FileExists(objItem.GetLink.Path) Then
                Set FileItem = Fso.GetFile(objItem.GetLink.Path)
                Cells(i, 4) = FileItem.Type
            End If
        End If
    Next objItem
End Sub