'*********************
'Sources:
'http://support.microsoft.com/kb/466935/fr
'http://support.microsoft.com/kb/160042/fr
'http://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

Declare Function WNetGetConnection Lib "mpr.dll" Alias _
    "WNetGetConnectionA" (ByVal lpszLocalName As String, _
    ByVal lpszRemoteName As String, ByRef cbRemoteName As Long) As Long
 
 
Sub Test()
    Dim Lettre As String
    Dim Cible As String * 255
     
    Cible = String$(255, Chr$(32))
    Lettre = "W:"
    WNetGetConnection Lettre, Cible, 255
     
    MsgBox Trim(Cible)
End Sub

Sub listerUNCPath()
    Dim wNwk As Object, oDrives As Object
    Dim i As Integer
    
    Set wNwk = CreateObject("WScript.Network")
    Set oDrives = wNwk.EnumNetworkDrives
    
    For i = 0 To oDrives.Count - 1 Step 2
        Debug.Print oDrives.Item(i) & " - " & oDrives.Item(i + 1)
    Next
End Sub

Sub CheminRepertoiresSpeciaux()
    'Testé avec Excel2002 & 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 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

Option Explicit
Option Base 1


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 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\mimi\dossier\excel"
    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(2, 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 ---
    For i = 1 To m
        Cells(i, 1) = Tableau(1, i)
        Cells(i, 2) = Tableau(2, i)
    Next i
    
    'Pour transférer par ordre croissant:
    'For i = m To 1 Step -1
        'Cells(m - i + 1, 1) = Tableau(1, i)
        'Cells(m - i + 1, 2) = Tableau(2, i)
    'Next i
    
    'Ajuste la taille des colonnes
    Columns("A:B").AutoFit
End Sub

Option Explicit
Dim i As Integer
Dim Cible As Byte


Sub listeDossiersEtSousDossiers()
    Dim Racine As String
    Application.ScreenUpdating = False
    
    Racine = "C:\Documents and Settings\mimi\dossier\general\excel"
    Cible = NbSeparateur(Racine)
    ListeDossiers Racine
    
    Application.ScreenUpdating = True
    i = 0
End Sub



Sub ListeDossiers(NomRep As String)
    'Adapté de Ole P Erlandsen
    Dim Fso As Object, SourceFolder As Object
    Dim SubFolder As Object
    
    On Error GoTo Fin
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(NomRep)
    
    For Each SubFolder In SourceFolder.SubFolders
            
        i = i + 1
        'pour récupérer le chemin complet
        'Cells(i, nbSeparateur(SubFolder.Path) - Cible) = SubFolder.Path
        '
        'pour récupérer uniquement le nom du dossier
        Cells(i, NbSeparateur(SubFolder.Path) + 1 - Cible) = SubFolder.Name
        ListeDossiers SubFolder.Path
    Next SubFolder

Fin:
End Sub


Function NbSeparateur(Chemin As String) As Byte
    Dim m As Integer
    Dim Nb As Byte
    
    For m = 1 To Len(Chemin)
        If Mid(Chemin, m, 1) = "\" Then
            Nb = Nb + 1
            m = m + 1
        End If
    Next
    
    NbSeparateur = Nb
End Function

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()
    '
    '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:\Documents and Settings\mimi\dossier\general\excel\PivotTable_UserForm.xls"
    
    '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

    ' convert system time to local time
    SystemTimeToFileTime udtSystemTime, udtLocalTime
    ' convert local time to GMT
    LocalFileTimeToFileTime udtLocalTime, udtFileTime
    ' open the file to get the filehandle
    
    lngHandle = CreateFile(Fichier, GENERIC_WRITE, _
        FILE_SHARE_READ Or FILE_SHARE_WRITE, _
        ByVal 0&, OPEN_EXISTING, 0, 0)
    ' change date/time property of the file
    SetFileTime lngHandle, udtFileTime, udtFileTime, udtFileTime
    ' close the handle
    CloseHandle lngHandle
End Sub