XL 2019 Pb avec PtrSafe

[JohnBill]

Bonjour à tout le forum.
Je viens vous trouver car je rencontre un problème avec un de mes fichiers (que j'avais élaboré avec l'aide de plusieurs membres du forum) et qui me sert à cataloguer mes CDs depuis plusieurs années.
Suite à une mise à jour d'Office, j'ai eu un message me demandant de mettre à jour les déclarations de fonctions pour fonctionner en 64 bits alors que tout fonctionnait parfaitement depuis des années. J'ai donc rajouté la mention "PtrSafe" devant les fonctions.
Mais maintenant, lorsque je clique sur le bouton de recherche dans l'onglet "RechercheSurDisques", j'ai un blocage de la procédure sur "SHBrowseForFolder" et pour moi, c'est incompréhensible.
Quelqu'un peut il m'aider à résoudre ce problème ?
NB : je joins le fichier et les autres macros fonctionnent.
Merci d'avance.

 

[patricktoulon]

bonjour
il faudrait d'abords t'expliquer sur le fait de l'utilité de ces deux api
sanchant que tu utilise FSO je vois pas trop a quoi pourrait te servir ces deux api
sachant quec le FSO
l'object folder ou file item ont les propriété path , dateceated , lastmodified , name ,etc......

mais si tu y tiens essaie ca

#If VBA7 Then
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
#Else
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
#End If

 

[JohnBill]

Bonjour et merci de ta réponse.Malgré la modification conseillée, j'ai toujours l'erreur sur "SHBrowseForFolder".
J'avais déjà essayé cette double fonction (32 et 64 bits).
Je voudrais quand même expliquer que j'ai démarré la création de ce fichier en 2011 avec l'aide des membres de cette communauté et de nombreuses modifications tout au long de sa mise au point. L'extraction fonctionnant très bien, je l'ai ensuite amélioré avec d'autres fonctionnalités. Je n'ai pas cherché plus loin. S'il y avait des instructions en plus, je les ai laissées.
Maintenant si il y a une autre solution pour extraire les fichiers d'un répertoire afin de les lister, je suis preneur.
Merci d'avance.

 

[MJ13]

Bonjour JohnBill, Patrick

Il me semble que Ptrsafe, c'est pour les version d'Excel 64 bits, ce que je déconseille en général.

Il faudrait peut être tester la version d'Excel au démarrage du classeur.

 

[patricktoulon]

deja ces deux api servent a ouvrir un dialog de sélection de folder(dossier)
pour choisir un dossier racine et pas a lister les fichier dedans
donc pour commencer
remplace tout ceci

Private Type BROWSEINFO    ' pour function LoadNomDuRep
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
#If VBA7 Then
    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
#Else
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
#End If

Public Function LoadNomDuRep() As String    ' retourne le nom du rep sélectionné
    Dim bInfo As BROWSEINFO, Path As String, R As Long, X As Long, Pos As Integer
    bInfo.pidlRoot = 0&    ' Root folder = Desktop
    bInfo.lpszTitle = "Selectionner un répertoire"    'titre
    bInfo.ulFlags = &H1    ' Type directory
    X = SHBrowseForFolder(bInfo)    'aff dialog
    ' traite résultat
    Path = Space$(512): R = SHGetPathFromIDList(ByVal X, ByVal Path)
    If R Then
        Pos = InStr(Path, Chr$(0)): LoadNomDuRep = Left(Path, Pos - 1)
    Else
        LoadNomDuRep = ""
    End If
End Function

par simplement cela

Public Function LoadNomDuRep() As String    ' retourne le nom du rep sélectionné
    Dim sFolder As String
    ' Open the select folder prompt
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then    ' if OK is pressed
            LoadNomDuRep = .SelectedItems(1)
        Else
            LoadNomDuRep = ""
        End If
  
End With
End Function

bon ben là on y vois déjà plus clair

 

[patricktoulon]

en suite tu me diras si quand tu liste tu a parfois des erreur 53 ,52 ou 72
elle se produisent quand dans les noms de fichiers il y a des caractères particuliers ou que le nom est trop long
j'ai la solution pour ca aussi

 

[patricktoulon]

pour la liste chez moi je met les jpeg des jaquettes et autre fichier dans les dossier respectif des album
pour ne lister que les musiques ".mp3 .wave .mp4" ajoute une condition

Public Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean, TestRetour)
'exp: ListFilesInFolder "C:\FolderName\", True < avec sous dossiers) !!! récursivité (***)
    Dim FSO, SourceFolder, SubFolder, FileItem, R As Long
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    If TestRetour = 0 Then
        Cells.Clear
        Columns.ColumnWidth = 10
        Cells(3, 1) = "Fichier": Cells(3, 2) = "Créé": Cells(3, 3) = "Modifié": Cells(3, 4) = "Capacité": Cells(3, 5) = "Chemin"
    End If
    R = Range("A65536").End(xlUp).Row + 1
    For Each FileItem In SourceFolder.Files
        If ".mp3 .wave .mp4" Like "*" & Right(FileItem.Name, 4) & "*" Then ' pour ne pas lister les images des jacquettes
        Cells(R, 1).Formula = FileItem.Name
        Cells(R, 2).Formula = FileItem.DateCreated
        Cells(R, 3).Formula = FileItem.DateLastModified
        If FileItem.Size >= 1024 Then
            Cells(R, 4).Formula = Int(FileItem.Size / 1024) & " Ko"
        Else
            Cells(R, 4).Formula = FileItem.Size & " Oct"
        End If
        ActiveSheet.Hyperlinks.Add Cells(R, 5), FileItem.Path    ' FileItem.Name
        'Cells(R, 5).Formula = SourceFolderName 'FileItem.Path
        R = R + 1
    End If
    Next
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True, 1    '(***)
        Next
    End If
    Columns.AutoFit
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Sub

fonctionne très bien chez moi

 

[JohnBill]

Merci pour la réponse de MJ13. J'ai voulu mettre une version d'excel plus récente et c'est pourquoi il est passé en 64 bits (Ce que j'ignorait).
Et un gros merci à PatrikToulon. Je vais créer un nouveau fichier avec tes macros dans l'après midi ou demain. Je les agrémenterais du module pour séparer les musiques du reste, ce que je faisait manuellement.
Je t'informerais si erreurs et bien sur si tout fonctionne.
Merci et au travail;

 

[patricktoulon]

tu veux le fichier? je te le donne si tu veux

 

[JohnBill]

Avec grand plaisir. Ça me donnera des idées. Encore merci

 

[kiki29]

Salut, si tu es curieux cela peut aider, il y a peut être mieux ?

 

[patricktoulon]

re
merci @kiki29 pour la source

et dans des temps immémoriaux en VBS, on utilisait ceci aussi (qui fonctionne aussi en VBA
retourne rien si "annuler"

Sub TEST()
    MsgBox getFolder
End Sub
Function getFolder()
    Dim ShellApp As Object, folder As Object
    Set ShellApp = CreateObject("Shell.Application")
    Set folder = ShellApp.BrowseForFolder(0, "CHOISIR UN DOSSIER", 0, "")
    If Not folder Is Nothing Then getFolder = folder.Self.Path
End Function

purée j'ai dépoussiéré mon disk de sources VBS

voilà comme vous pouvez le voir ,on peut se passer de l' api usine a gaz "SHBrowseForFolderA"

 

[JohnBill]

J'ai effectué le remplacement et maintenant cela fonctionne à nouveau nickel. Je voudrais remercier tous les intervenants de ce fil pour l'aide qu'il m'ont apporté dans mes soucis résolus.

 

[patricktoulon]

re
juste une question?
pourquoi des lien hypertlink dans les cellules ?
c'est pour ouvrir le fichier dans le lecteur par défaut ?

 

[JohnBill]

Exact. A l'occasion.