Accueil
Accueil Le Club Delphi Kylix C C++ Java J2EE DotNET & C# Visual Basic Access Pascal Dev Web PHP ASP XML UML SQLSGBD Windows Linux Autres
logo

precedent    sommaire    suivant   


Comment vérifier si un fichier existe ?
auteurs : SilkyRoad, Philben
Vba

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

Comment vérifier si un dossier existe ?
auteur : SilkyRoad
Vba

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

Comment retrouver les répertoires parents ?
auteur : SilkyRoad
La procédure récupère le répertoire parent du classeur contenant cette macro.

Vba

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



Cet exemple remonte 2 répertoires parents, par rapport au chemin du classeur contenant la macro.

Vba

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

Comment créer un dossier ?
auteur : SilkyRoad
Utilisez l'instruction MkDir.
Attention, un message d'erreur survient si le répertoire parent n'existe pas.


L'exemple crée un dossier "Archives" dans "C:\Documents and Settings\dossier".

Vba

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

Comment ouvrir l'explorateur Windows sur un répertoire défini ?
auteur : SilkyRoad
4 méthodes sont ici proposées:

Vba

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

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

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
Vba

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

Comment boucler sur les fichiers d'un répertoire ?
auteur : SilkyRoad
Vba

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

Comment compter le nombre de fichiers dans un répertoire ?
auteur : Random
Vba

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



Ce deuxième code permet de définir les extensions de fichier à compter.
Vous pouvez indiquer autant d'extensions que vous voulez.

Vba

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

Comment renommer un fichier ?
auteur : SilkyRoad
Utilisez l'instruction Name.
Cette instruction permet aussi de renommer les répertoires.

Remarque:
Une erreur survient si le fichier à renommer est déjà ouvert.

Vba

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

Comment modifier la date de création d'un fichier ?
auteur : SilkyRoad
Vba

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

Comment envoyer un fichier dans la corbeille ?
auteur : SilkyRoad
En VBA, l'instruction Kill permet de supprimer un fichier, mais celui est alors définitivement effacé de votre PC.
Le code suivant transfère le fichier dans la corbeille et il peut donc être récupéré en cas d'erreur.
Utilisez .fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION pour ne pas afficher le message confirmation de la suppression du fichier.

Vba

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

Comment retrouver facilement le chemin des répertoires spéciaux Windows ?
auteur : SilkyRoad
Cet exemple affiche le chemin de "Mes documents".

Adaptez la valeur de la constante en fonction du répertoire à identifier.

Vba

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

Comment retrouver la taille des éléments de la corbeille ?
auteur : SilkyRoad
Remarque:
Cet exemple ne boucle pas sur les sous dossiers complets éventuellement contenus dans la corbeille.

Vba

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

Comment récupérer des informations sur les applications du PC ?
auteur : SilkyRoad
Sélectionnez n'importe quel type de fichier à partir de la boîte de dialogue (GetOpenFileName). La procédure va ensuite récupérer le nom de l'exécutable associé à ce fichier et retourner des informations sur le programme, notamment:

Le nom de l'éditeur
La description du programme
La version du fichier
Le nom interne
Le copyright
Le nom de l'application
Le nom du produit
La version du produit


Testé sous XL97,XL2000,XL2002

Vba

'*********************
'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  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

Comment lister les fichiers d'un répertoire par ordre décroissant de date de création ?
auteur : SilkyRoad
La procédure liste les fichiers d'un répertoire par ordre décroissant de création.
Vous trouverez en commentaire les paramètres pour utiliser la date de dernière modification des fichiers.

Vba

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

Comment lister les fichiers contenus dans un répertoire ainsi que dans tous ses sous-répertoires ?
auteur : SilkyRoad
Vba

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
lien : Manipulation des fichiers en VBA

Comment copier un fichier vers un autre répertoire ?
auteur : SilkyRoad
Vous pouvez utiliser l'instruction FileCopy.
Le fichier à copier doit impérativement être fermé sinon une erreur se produit.

Vba

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

Comment lister les lecteurs en réseau et leur nom UNC ?
auteur : SilkyRoad
La procédure permet d'obtenir la liste des répertoires en réseau ainsi que leus nom UNC (Universal Naming Convention qui est utilisé ainsi: \\NomPcDistant\dossier\...)

Vba

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

Comment créer un raccourci sur le bureau ?
auteur : SilkyRoad
Cet exemple crée un raccourci sur le bureau pour le classeur contenant cette macro. Le classeur est supposé déjà sauvegardé sur le PC.

Vba

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

Comment vider le répertoire des documents récemment utilisés ?
auteur : SilkyRoad
Vba

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

precedent    sommaire    suivant   

Consultez les autres F.A.Q's


Les sources présentés sur cette pages sont libre de droits, et vous pouvez les utiliser à votre convenance. Par contre cette page de présentation de ces sources constitue une oeuvre intellectuelle protégée par les droits d'auteurs. Copyright ©2008  Developpez LLC. Tout droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à 3 ans de prison et jusqu'à 300 000 E de dommages et intérets. Cette page est déposée à la SACD.

Vos questions techniques : forum d'entraide Accueil - Publiez vos articles, tutoriels, cours et rejoignez-nous dans l'équipe de rédaction du club d'entraide des développeurs francophones. Nous contacter - Copyright 2000..2005 www.developpez.com