copie du chemin d'un répertoire dans une cellule

[babap1]

Bonsoir le forum,

je souhaite créer un bouton qui agit comme ctrl + o pour choisir un dossier sur mon disque et en copier le chemin d'accès dans une cellule...

Jusque là ça va, j'ai réccupéré n bout de code sur le forum :

Private Function ChoisirDossier()
Dim objShell, objFolder, chemin, SecuriteSlash

Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
chemin = "C:\Windows\Bureau"
End If
If objFolder.Title = "" Then
chemin = ""
End If

SecuriteSlash = InStr(objFolder.Title, ":")

If SecuriteSlash > 0 Then
chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
ChoisirDossier = chemin
Range("A1").Value = chemin
End Function

Mais j'aimerai faire un test sur le dossier selectionné (chemin) pour être sur que le dossier selectionné contienne d'autres dossiers spécifique.

Quelqu'un a une idée ? Merci d'avance, bap

 

[ninbihan]

Re : copie du chemin d'un répertoire dans une cellule

Bonsoir Bap,

Dans le code du bouton tu peux assayer ceci:
Range("Tacellule")=application.getopenfilename

Bonne soirée,

Ninbihan

 

[babap1]

Re : copie du chemin d'un répertoire dans une cellule

Bonsoir ninbihan,

j'avais pensé à la methode getOpenFilename aussi mais elle ne me permet pas de sélectionner des dossiers, seulement des fichiers je crois...

A plus, bonne soirée

 

[ninbihan]

Re : copie du chemin d'un répertoire dans une cellule

Re,

En affectant le code que tu as trouvé au bouton:

Private Sub ChoisirDossier()
Dim objShell, objFolder, chemin, SecuriteSlash

Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
chemin = "C:\Windows\Bureau"
End If
If objFolder.Title = "" Then
chemin = ""
End If

SecuriteSlash = InStr(objFolder.Title, ":")

If SecuriteSlash > 0 Then
chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If

Range("A1").Value = chemin
End Sub

 

[babap1]

Re : copie du chemin d'un répertoire dans une cellule

Re,

j'ai un souci avec cette procedure : je ne vois pas où je peux configurer le Shell.Application puisque ni le texte des boutons ni le titre de la fenêtre n'est pas configurable dans le code tel quel....

les boutons du Shell sont : "créer un nouveau dossier", "ok" et "annuler" et le titre "Rechercher un dossier" et j'aimerai avoir de l'Anglais moi !!

Quelqu'un pense à quelque chose ?

Merci d'avance, Bap

 

[Jam]

Re : copie du chemin d'un répertoire dans une cellule

Bonjour à tous,

En utilisant les API cela donne cela (à mettre dans un module) puis utiliser un bouton dans la feuille pour appeler la procédure Test:

Option Explicit

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    lImage As Long
End Type

'# Declaration des fonctions API (32 bits) #
'// BrowseForFolder \\
Declare Function SHGetPathFromIDList Lib "Shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszpath As String) As Long
    
Declare Function SHBrowseForFolder Lib "Shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

'=====================
'BrowseForFolder (API)
'=====================
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
    bInfo.lpszTitle = "Sélectionner un dossier"
Else
    bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
    pos = InStr(path, Chr$(0))
    GetDirectory = Left(path, pos - 1)
Else
    GetDirectory = ""
End If
End Function

'========
' A appeler à partir d'un bouton dans une feuille
'========
Sub test()
Dim x As String
x = GetDirectory
Range("A1") = x
End Sub

HTH

 

[babap1]

Re : copie du chemin d'un répertoire dans une cellule

Bonsoir Jam,

Merci pour ton code mais cela ne me permet pas de changer le titre de la fenêtre qui s'ouvre... c'est toujours "Rechercher un dossier" et mes boutons sont toujours en français.

La seule différence avec ma procédure ChoisirDossier() est que je n'ai plus le bouton "créer un nouveau dossier" !

A bientôt, bap

 

[Jam]

Re : copie du chemin d'un répertoire dans une cellule

Re babap1,

Aaaaah, tu voulais de l'anglais ! C'était pas évident dans ton premier post 🙁

Cependant comme les API ou les vbscript utilisent la langue de l'OS tu auras toujours du français...et de l'anglais si tu envois ces bouts de code à l'étranger 😉

Dans le cas des API, tu peux toujours rajouter un message (le Optional Msg de GetDirectory) dans l'appel de la fonction. Exemple: x=GetDirectory("Select a folder, please"). Cette option est à moitié satisfaisante, j'en convient.

Sinon, tu as aussi la possibilité de le faire complètement mais il te faudra:
- Créer un formulaire de tout pièce
- y mettre les bouton "OK" et "Cancel"
- Insérer un contrôle "Treeview" pour gérer les arborescence du disque et entre nous ce contrôle est loin d'être le plus sympathique à traiter...mais avec de la patience tout est possible.

Bon courage,

 

[babap1]

Re : copie du chemin d'un répertoire dans une cellule

les API ou les vbscript utilisent la langue de l'OS

Bonsoir le forum, Jam,

merci pour toutes tes réponses et ta précision. Si les API utilisent la langue de l'OS alors ça me convient tout à fait.

Merci beaucoup et @ bientôt,
Bap