Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long Type BrowseInfo hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Sub creer_diapo(nouv) Dim zaza As String, brinf As BrowseInfo Set fs = CreateObject("Scripting.FileSystemObject") ThisWorkbook.Sheets("images").Select nomrep = Cells(1, 2) If nouv Then '******************************** 'présentation If MsgBox("Le logiciel crée un ""diaporama html"" permettant de visionner les images contenues dans un répertoire que vous devez sélectionner" & Chr(10) & "voulez-vous créer un diaporama ?", vbYesNo, "diaporama html") = vbNo Then Exit Sub 'nom du répertoire contenant les images autr = vbYes If nomrep <> "" Then autr = MsgBox("le répertoire " & nomrep & " est sélectionné." & Chr(10) & "Voulez-vous choisir un autre répertoire contenant ldes images ?", vbYesNo, "diaporama") If autr = vbYes Then dialg = SHBrowseForFolder(brinf) 'affiche la boite de dialogue zaza = Space(200) 'crée un tampon zaza SHGetPathFromIDList dialg, zaza 'charge le chemin dans le tampon nomrep = Left(zaza, InStr(1, zaza, Chr(0)) - 1) End If If Right(nomrep, 1) = "\" Then nomrep = Left(nomrep, Len(nomrep) - 1) 'traiter le cas où nomrep est un disque ou un nom non valide If Not fs.folderexists(nomrep) Or UCase(fs.getdrivename(nomrep)) = UCase(Application.WorksheetFunction.Substitute(nomrep, "\", "")) Then MsgBox "nom de répertoire non valide", , "diaporama" Exit Sub End If 'lister les images ds le fichier excel If Cells(1, 2) = nomrep And Cells.Find("*", , , , , xlPrevious).Row > 1 Then garder = MsgBox("voulez-vous conserver la liste de fichiers image de l'onglet ""images"" ?", vbYesNoCancel, "diaporama") End If If garder = vbCancel Then Exit Sub If garder <> vbYes Then 'effacer tout Cells.ClearContents 'lister Cells(1, 1) = "n° ordre" Cells(1, 2) = nomrep Cells(1, 3) = "titre" lin = 1 nomimg = Dir(nomrep & "\*.???") nouv: If LCase(Right(nomimg, 4)) = ".jpg" Or LCase(Right(nomimg, 4)) = ".gif" Or LCase(Right(nomimg, 4)) = ".bmp" Then lin = lin + 1 Cells(lin, 1) = lin - 1 Cells(lin, 2) = nomimg Cells(lin, 3) = nomimg Do While Right(Cells(lin, 3), 1) <> "." Cells(lin, 3) = Left(Cells(lin, 3), Len(Cells(lin, 3)) - 1) Loop Cells(lin, 3) = Left(Cells(lin, 3), Len(Cells(lin, 3)) - 1) End If Cells(lin, 3) = WorksheetFunction.Substitute(Cells(lin, 3), "_", " ") nomimg = Dir If nomimg <> "" Then GoTo nouv End If 'nom du fichier "retour" defaut = "diapos.html" If Cells(1, 4) <> "" Then defaut = Cells(1, 4) fichretour = InputBox("nom ou adresse du fichier vers lequel pointe le lien ""retour"" (fichier html)", "diaporama", defaut) Cells(1, 4) = fichretour End If 'fin de nouv=true ************************************** 'trier le fichier derlin = Cells.Find("*", , , , , xlPrevious).Row Rows("2:" & derlin).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'renuméroter pour éviter les doublons derlin = Cells.Find("*", , , , , xlPrevious).Row For lignn = 2 To derlin Cells(lignn, 1) = lignn - 1 Next 'création du fichier texte Set fichdiapo = fs.OpenTextFile(nomrep & "\" & "diapos.html", 2, True) fichdiapo.WriteLine "" fichdiapo.WriteLine "" fichdiapo.Close MsgBox "la page html ""diapos.html"" a été enregistrée dans le répertoire """ & nomrep & """ contenant les images à visionner", , "diaporama" 'ouverture de la page html ThisWorkbook.FollowHyperlink nomrep & "\diapos.html", , True End Sub