Boucle For Next macro Excel qui bloque

Le 24/11/2023 à 13:22

Bonjour,

J'ai une macro qui doit se répéter sur tous les fichiers du répertoire identifié, j'ai essayé plusieurs possibilités, sans succès.

Le premier fichier se passe bien, et ensuite sur la boucle ca s'arrête en débogage sur FiChoisi.Close False

Merci d'avance sur votre aide.

Sub ChoisirPhoto2()
'Désigner une photo, importer des propriétés EXIF, créer une miniature
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Dim WSh As Worksheet, LO As ListObject, Lgn As Range
Set WSh = Sh_Liste
Set LO = WSh.ListObjects("tb_Photos")

Dim FSO As New FileSystemObject
Dim FiChoisi As Variant, FiNom$, FiRép$, RéfAltitude$, CheminTmp$

Dim Image As Shape, Img As New WIA.ImageFile, IP As New WIA.ImageProcess
Dim Ps As WIA.Properties, P As WIA.Property
Dim FileName As String
Dim i As Integer
i = 1
For i = i To 700

FiChoisi = ThisWorkbook.Path & "\PHOTOS\" & i & ".jpg"
'InitialFileName = (ThisWorkbook.Path & "\PHOTOS\1.jpg")
If FiChoisi = False Then Exit Sub

FiNom = FSO.GetFileName(FiChoisi)
FiRép = Replace(FiChoisi, FiNom, "")

'Ligne sur laquelle enregistrer les données
With WSh.Evaluate(LO.Name)
Set Lgn = .Rows(.Rows.Count)
'Vérifier que la ligne ne contient que la formule sinon se décaler vers le bas
If WorksheetFunction.CountA(Lgn) > 1 Then Set Lgn = Lgn.Offset(1)
End With

'Charger la photo, récupérer ses propriétés
Img.LoadFile FiChoisi
Set Ps = Img.Properties

'Récupération des données EXIF
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Altitude
Niveau = ""
Altitude = ""
If Ps.Exists("GpsAltitudeRef") Then
Set P = Ps("GpsAltitudeRef")
Niveau = P.Value
Select Case Niveau
Case 0
signe = 1
Case 1
signe = -1
End Select
If Ps.Exists("GpsAltitude") Then Altitude = signe * LireAltLatLong(Ps("GpsAltitude"))
End If
'Latitude
LatitudeRéf = ""
Latitude = ""
If Ps.Exists("GpsLatitudeRef") Then
Set P = Ps("GpsLatitudeRef")
LatitudeRéf = P.Value
Select Case LatitudeRéf
Case "N"
signe = 1
Case "S"
signe = -1
End Select
If Ps.Exists("GpsLatitude") Then Latitude = signe * LireAltLatLong(Ps("GpsLatitude"))
End If
'Longitude
LongitudeRéf = ""
Longtitude = ""
If Ps.Exists("GpsLongitudeRef") Then
Set P = Ps("GpsLongitudeRef")
LongitudeRéf = P.Value
Select Case LongitudeRéf
Case "E"
signe = 1
Case "O", "W"
signe = -1
End Select
If Ps.Exists("GpsLongitude") Then Longitude = signe * LireAltLatLong(Ps("GpsLongitude"))
End If
'Auteur
Auteur = ""
If Ps.Exists("Artist") Then Auteur = Ps("Artist").Value
'Date du cliché
DateCliché = ""
If Ps.Exists("DateTime") Then DateCliché = Replace(Ps("DateTime"), ":", "/", 1, 2)

'Orientation de la photo (pour obtenir une orientation correcte de la miniature)
If Ps.Exists("Orientation") Then
Select Case Ps("Orientation").Value
Case 1
RotationAngle = 0
FlipHorizontal = False
Case 2
RotationAngle = 0
FlipHorizontal = True
Case 3
RotationAngle = 180
FlipHorizontal = False
Case 4
RotationAngle = 180
FlipHorizontal = True
Case 5
RotationAngle = 90
FlipHorizontal = False
Case 6
RotationAngle = 90
FlipHorizontal = False
Case 7
RotationAngle = 270
FlipHorizontal = True
Case 8
RotationAngle = 270
FlipHorizontal = False
End Select
End If

'Créer une vignette (100 x 100 maxi)
'Orientation
IP.Filters.Add IP.FilterInfos("RotateFlip").FilterID
IP.Filters(1).Properties("RotationAngle") = RotationAngle
IP.Filters(1).Properties("FlipHorizontal") = FlipHorizontal
'Réduction à 100 pixels max (largeur ou hauteur) en gardant les proportions
IP.Filters.Add IP.FilterInfos("Scale").FilterID
IP.Filters(2).Properties("MaximumHeight") = 100
IP.Filters(2).Properties("MaximumWidth") = 100
'Application des transformations via les filtres
Set Img = IP.Apply(Img)

'Enregistrement temporaire du fichier miniature (le temps d'importer la miniature)
CheminTmp = "C:\tmp_img\"
On Error Resume Next
MkDir CheminTmp
Kill CheminTmp & "Thumb" & FiNom
On Error GoTo 0
Img.SaveFile CheminTmp & "Thumb" & FiNom

'Enregistrement des propriétes EXIF à la fin du tableau
With Lgn
.Cells(2) = FiRép
.Cells(3) = FiNom
.Cells(4) = Auteur
.Cells(5) = DateCliché
.Cells(6) = Niveau
.Cells(7) = Altitude
.Cells(8) = LatitudeRéf
.Cells(9) = Latitude
.Cells(10) = LongitudeRéf
.Cells(11) = Longitude
End With

Set Image = WSh.Shapes.AddPicture(FileName:=CheminTmp & "Thumb" & FiNom, _
linktofile:=msoFalse, SaveWithdocument:=msoCTrue, _
Top:=Lgn.Cells(1, 1).Left, Left:=Lgn.Cells(1, 1).Top, Width:=-1, Height:=-1)

With Image
'Renommer l'image importée
.Name = Format(Now, "yyyy:mm:dd_hh:mm:ss")
Lgn.Cells(1) = .Name
.Rotation = 0
'Position (bis) sur le coin sup gauche de la 1ère cellule de la ligne (+1 pour être dans la cellule)
.Left = Lgn.Cells(1, 1).Left + 1
.Top = Lgn.Cells(1, 1).Top + 1
'Conserver le ratio H/L avant le redimensionnement
.LockAspectRatio = msoTrue
'Réglage de la hauteur (= hauteur de la ligne -2)
.Height = Lgn.Cells(1, 1).Height - 2
'Texte de remplacement
.AlternativeText = ""
'Associer à la macro "MontrerPhoto" (via clic)
.OnAction = "MontrerPhoto"
End With

'Supprimer le fichier miniature temporaire
Kill CheminTmp & "Thumb" & FiNom

Set P = Nothing: Set Ps = Nothing: Set IP = Nothing: Set Img = Nothing: Set Image = Nothing
Set Lgn = Nothing: Set LO = Nothing: Set WSh = Nothing
Set FSO = Nothing
FiChoisi.Close False

Next i
End Sub

Function LireAltLatLong(P As Property) As Variant
'Interpréte la propriété (Valable pour altitude, latitude, et longitude)
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
LireAltLatLong = ""
If P.IsVector Then
If TypeOf P.Value Is Vector Then
If TypeOf P.Value(1) Is Rational And TypeOf P.Value(2) Is Rational And TypeOf P.Value(2) Is Rational Then
LireAltLatLong = P.Value(1).Numerator / P.Value(1).Denominator + _
(P.Value(2).Numerator / P.Value(2).Denominator) / 60 + _
(P.Value(3).Numerator / P.Value(3).Denominator) / 3600
End If
End If
ElseIf TypeOf P.Value Is Rational Then
LireAltLatLong = P.Value.Numerator / P.Value.Denominator
End If
Set P = Nothing
End Function

Sub MontrerPhoto()

End Sub
'Charge la photo appelante et la ré-oriente correctement
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Dim repère$, ShpImage As Shape, C As Range, NomFichier$, NomCompletFichier$
Dim Image As Picture, Img As New WIA.ImageFile, IP As New WIA.ImageProcess
Dim Ps As WIA.Properties, P As WIA.Property
Dim TempAffichage%

On Error Resume Next
repère = Application.Caller
If repère = "" Then Exit Sub

'Shape Appelante
Set ShpImage = ActiveSheet.Shapes(repère)
On Error GoTo 0
If ShpImage Is Nothing Then Exit Sub

'Récupérer le nom du fichier via la cellule contenant la miniature
Set C = ShpImage.TopLeftCell
NomFichier = C.Offset(0, 2)
NomCompletFichier = C.Offset(0, 1) & NomFichier

'Vérifier l'existence du fichier
If Dir(NomCompletFichier) = "" Then
Msg = "Le fichier : " & NomCompletFichier & Chr(10) & "n'existe plus"
Style = vbOKOnly + vbExclamation
Title = "Affichage photo "
Resp = MsgBox(Msg, Style, Title)
Exit Sub
End If

'Charger l'image
Img.LoadFile NomCompletFichier
'Récupérer ses propriétés
Set Ps = Img.Properties

'Orientation de la photo (pour obtenir une orientation correcte dans le UserForm)
If Ps.Exists("Orientation") Then
Select Case Ps("Orientation").Value
Case 1
RotationAngle = 0
FlipHorizontal = False
Case 2
RotationAngle = 0
FlipHorizontal = True
Case 3
RotationAngle = 180
FlipHorizontal = False
Case 4
RotationAngle = 180
FlipHorizontal = True
Case 5
RotationAngle = 90
FlipHorizontal = False
Case 6
RotationAngle = 90
FlipHorizontal = False
Case 7
RotationAngle = 270
FlipHorizontal = True
Case 8
RotationAngle = 270
FlipHorizontal = False
End Select
End If
'Orientation
IP.Filters.Add IP.FilterInfos("RotateFlip").FilterID
IP.Filters(1).Properties("RotationAngle") = RotationAngle
IP.Filters(1).Properties("FlipHorizontal") = FlipHorizontal
''Application des transformations via les filtres
Set Img = IP.Apply(Img)
'Enregistrement temporaire du fichier miniature (le temps d'importer la miniature)
CheminTmp = "C:\tmp_img\"
On Error Resume Next
MkDir CheminTmp
Kill CheminTmp & NomFichier
On Error GoTo 0
Img.SaveFile CheminTmp & NomFichier

'Affichage dans le UserForm pendant 3 s
TempAffichage = 3
With UsF_Photo
.Caption = NomCompletFichier
.Picture = LoadPicture(CheminTmp & NomFichier)
Kill CheminTmp & NomFichier
.Show
DoEvents
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait Now + TimeSerial(0, 0, TempAffichage)
End With
Unload UsF_Photo

End Sub

EDIT modo : Bonjour et bienvenue. SVP code à mettre entre balises avec le bouton </> . Merci d'y faire attention la prochaine fois

Le 24/11/2023 à 14:53

Bonjour Alea83500, le forum,

Sub MontrerPhoto()

End Sub ' << ceci est de trop

'Charge la photo appelante et la ré-oriente correctement

...

...

Le End Sub sous Sub MontrerPhoto() est de trop et bloque le code en dessous.

Bizarre

Le 24/11/2023 à 17:04

Bonjour Alea83500,

Ton Fichoisi est un chemin pour aller chercher une image.

Faire Fichoisi = ""

Ainsi ton chemin sera vide en fin de boucle et tu pourras rechercher une autre image par un nouveau chemin en début de boucle.

Le 27/11/2023 à 09:35

Bonjour,

Merci pour votre réponse.

J'ai enlevé le End Sub qui en effet ne devait pas se trouver la et maintenant ca bloque dés le départ et coince sur If FiChoisi = False Then Exit Sub et ne copie même pas le premier fichier.

Ci joint le fichier et le lien PHOTOS.

15202311071.zip (878.56 Ko)
Le 27/11/2023 à 12:21

bonjour,

une proposition de correction

Sub ChoisirPhoto2()
    'Désigner une photo, importer des propriétés EXIF, créer une miniature
    '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
    Dim WSh As Worksheet, LO As ListObject, Lgn As Object
    Set WSh = Sh_Liste
    Set LO = WSh.ListObjects("tb_Photos")

    Dim FSO As New FileSystemObject
    Dim FiChoisi As String, FiNom$, FiRép$, RéfAltitude$, CheminTmp$
    Dim Image As Shape, Img As New WIA.ImageFile, IP As New WIA.ImageProcess
    Dim Ps As WIA.Properties, P As WIA.Property
    Dim FileName As String

    For i = 1 To 700

        FiChoisi = ThisWorkbook.Path & "\PHOTOS\" & i & ".jpg"
        'InitialFileName = (ThisWorkbook.Path & "\PHOTOS\1.jpg")
        If Dir(FiChoisi) = "" Then Exit Sub

        FiNom = FSO.GetFileName(FiChoisi)
        FiRép = Replace(FiChoisi, FiNom, "")

        'Ligne sur laquelle enregistrer les données
        With WSh
            Set Lgn = LO.Range.Rows(LO.Range.Rows.Count)
            If Application.CountA(Lgn) > 1 Then Set Lgn = LO.ListRows.Add
            'Vérifier que la ligne ne contient que la formule sinon se décaler vers le bas
        End With

        'Charger la photo, récupérer ses propriétés
        Img.LoadFile FiChoisi
        Set Ps = Img.Properties

        'Récupération des données EXIF
        '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
        'Altitude
        Niveau = ""
        Altitude = ""
        If Ps.Exists("GpsAltitudeRef") Then
            Set P = Ps("GpsAltitudeRef")
            Niveau = P.Value
            Select Case Niveau
                Case 0
                    signe = 1
                Case 1
                    signe = -1
            End Select
            If Ps.Exists("GpsAltitude") Then Altitude = signe * LireAltLatLong(Ps("GpsAltitude"))
        End If
        'Latitude
        LatitudeRéf = ""
        Latitude = ""
        If Ps.Exists("GpsLatitudeRef") Then
            Set P = Ps("GpsLatitudeRef")
            LatitudeRéf = P.Value
            Select Case LatitudeRéf
                Case "N"
                    signe = 1
                Case "S"
                    signe = -1
            End Select
            If Ps.Exists("GpsLatitude") Then Latitude = signe * LireAltLatLong(Ps("GpsLatitude"))
        End If
        'Longitude
        LongitudeRéf = ""
        Longtitude = ""
        If Ps.Exists("GpsLongitudeRef") Then
            Set P = Ps("GpsLongitudeRef")
            LongitudeRéf = P.Value
            Select Case LongitudeRéf
                Case "E"
                    signe = 1
                Case "O", "W"
                    signe = -1
            End Select
            If Ps.Exists("GpsLongitude") Then Longitude = signe * LireAltLatLong(Ps("GpsLongitude"))
        End If
        'Auteur
        Auteur = ""
        If Ps.Exists("Artist") Then Auteur = Ps("Artist").Value
        'Date du cliché
        DateCliché = ""
        If Ps.Exists("DateTime") Then DateCliché = Replace(Ps("DateTime"), ":", "/", 1, 2)

        'Orientation de la photo (pour obtenir une orientation correcte de la miniature)
        If Ps.Exists("Orientation") Then
            Select Case Ps("Orientation").Value
                Case 1
                    RotationAngle = 0
                    FlipHorizontal = False
                Case 2
                    RotationAngle = 0
                    FlipHorizontal = True
                Case 3
                    RotationAngle = 180
                    FlipHorizontal = False
                Case 4
                    RotationAngle = 180
                    FlipHorizontal = True
                Case 5
                    RotationAngle = 90
                    FlipHorizontal = False
                Case 6
                    RotationAngle = 90
                    FlipHorizontal = False
                Case 7
                    RotationAngle = 270
                    FlipHorizontal = True
                Case 8
                    RotationAngle = 270
                    FlipHorizontal = False
            End Select
        End If

        'Créer une vignette (100 x 100 maxi)
        'Orientation
        IP.Filters.Add IP.FilterInfos("RotateFlip").FilterID
        IP.Filters(1).Properties("RotationAngle") = RotationAngle
        IP.Filters(1).Properties("FlipHorizontal") = FlipHorizontal
        'Réduction à 100 pixels max (largeur ou hauteur) en gardant les proportions
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        IP.Filters(2).Properties("MaximumHeight") = 100
        IP.Filters(2).Properties("MaximumWidth") = 100
        'Application des transformations via les filtres
        On Error Resume Next
        Set Img = IP.Apply(Img)
        On Error GoTo 0

        'Enregistrement temporaire du fichier miniature (le temps d'importer la miniature)
        CheminTmp = "C:\tmp_img\"
        On Error Resume Next
        MkDir CheminTmp
        Kill CheminTmp & "Thumb" & FiNom
        On Error GoTo 0
        Img.SaveFile CheminTmp & "Thumb" & FiNom

        'Enregistrement des propriétes EXIF à la fin du tableau
        With Lgn
            .Range(2) = FiRép
            .Range(3) = FiNom
            .Range(4) = Auteur
            .Range(5) = DateCliché
            .Range(6) = Niveau
            .Range(7) = Altitude
            .Range(8) = LatitudeRéf
            .Range(9) = Latitude
            .Range(10) = LongitudeRéf
            .Range(11) = Longitude
        End With

        Set Image = WSh.Shapes.AddPicture(FileName:=CheminTmp & "Thumb" & FiNom, _
        linktofile:=msoFalse, SaveWithdocument:=msoCTrue, _
        Top:=Lgn.Range(1).Left, Left:=Lgn.Range(1).Top, Width:=-1, Height:=-1)

        With Image
            'Renommer l'image importée
            .Name = Format(Now, "yyyy:mm:dd_hh:mm:ss")
            Lgn.Range(1) = .Name
            .Rotation = 0
            'Position (bis) sur le coin sup gauche de la 1ère cellule de la ligne (+1 pour être dans la cellule)
            .Left = Lgn.Range(1).Left + 1
            .Top = Lgn.Range(1).Top + 1
            'Conserver le ratio H/L avant le redimensionnement
            .LockAspectRatio = msoTrue
            'Réglage de la hauteur (= hauteur de la ligne -2)
            .Height = Lgn.Range(1).Height - 2
            'Texte de remplacement
            .AlternativeText = ""
            'Associer à la macro "MontrerPhoto" (via clic)
            .OnAction = "MontrerPhoto"
        End With

        'Supprimer le fichier miniature temporaire
        Kill CheminTmp & "Thumb" & FiNom
        '     FiChoisi.Close False
    Next i
    Set WSh = Nothing
    Set FSO = Nothing
    Set P = Nothing:     Set Ps = Nothing:     Set IP = Nothing:     Set Img = Nothing:     Set Image = Nothing
    Set LO = Nothing:
End Sub
Le 27/11/2023 à 12:42

Bonjour Alea83500, H2So4,

Exact, on teste par Dir si le fichier est présent vu que le chemin complet est un string. Si le test Dir retourne vide alors on sort de la procédure.

Mais il serait possible de sauter un ensemble de traitement et de continuer à boucler pour rechercher d'autres fichiers images.

Le 28/11/2023 à 10:04

Bonjour,

Merci pour votre aide.

Malheureusement ca ne fonctionne pas, et bloque sur :

With Lgn
.Range(2) = FiRép

Je vais avoir de 2 à 700 photos donc je n'ai pas le choix impossible d'aller les chercher une par une..

Le 28/11/2023 à 11:52

bonjour,

je pense que la feuille de ton classeur est protégée par un mot de passe et que cela empêche de modifier une ligne existante de ton tableau.

Le 28/11/2023 à 13:36

BOnjour,

Non pas de protection sur ce fichier, et il fonctionnait un par un.. je vous l'ai joint à mon précédent message..

Le 28/11/2023 à 14:11

re-bonjour,

je ne trouve pas d'explication, la macro fonctionne chez moi.

23traitementphoto.zip (475.87 Ko)
Le 28/11/2023 à 15:17

Re,

Je viens de réessayer avec votre fichier et idem ca me bloque sur : .Range(2) = FiRép

Je ne comprends pas non plus..

Le 29/11/2023 à 00:43

bonsoir,

une nouvelle version sans tableau structuré, (la formule pour l'hyperlien est ajoutée automatiquement)

24traitementphotov1.xlsm (257.85 Ko)
Sub ChoisirPhoto2()
    'Désigner une photo, importer des propriétés EXIF, créer une miniature
    '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
    Dim WSh As Worksheet, Lgn As Range
    Set WSh = Sh_Liste

    Dim FSO As New FileSystemObject
    Dim FiChoisi As String, FiNom$, FiRép$, RéfAltitude$, CheminTmp$
    Dim Image As Shape, Img As New WIA.ImageFile, IP As New WIA.ImageProcess
    Dim Ps As WIA.Properties, P As WIA.Property
    Dim FileName As String

    For i = 1 To 700

        FiChoisi = ThisWorkbook.Path & "\PHOTOS\" & i & ".jpg"
        'InitialFileName = (ThisWorkbook.Path & "\PHOTOS\1.jpg")
        If Dir(FiChoisi) = "" Then Exit For

        FiNom = FSO.GetFileName(FiChoisi)
        FiRép = Replace(FiChoisi, FiNom, "")

        'Ligne sur laquelle enregistrer les données

        Set Lgn = WSh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        With Lgn.Cells(1, "L")
            .Formula = "=IF(ISBLANK('BdD Photos'!$H3),"""",HYPERLINK(""https://maps.google.fr/maps?q=""&SUBSTITUTE(TEXT('BdD Photos'!$I3,""0,000000000000""),"","",""."")&"",""&SUBSTITUTE(TEXT('BdD Photos'!$K3,""0,000000000000""),"","",""."")&""&18Z&hl=fr"",""Localiser""))"
        End With

        'Charger la photo, récupérer ses propriétés
        Img.LoadFile FiChoisi
        Set Ps = Img.Properties

        'Récupération des données EXIF
        '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
        'Altitude
        Niveau = ""
        Altitude = ""
        If Ps.Exists("GpsAltitudeRef") Then
            Set P = Ps("GpsAltitudeRef")
            Niveau = P.Value
            Select Case Niveau
                Case 0
                    signe = 1
                Case 1
                    signe = -1
            End Select
            If Ps.Exists("GpsAltitude") Then Altitude = signe * LireAltLatLong(Ps("GpsAltitude"))
        End If
        'Latitude
        LatitudeRéf = ""
        Latitude = ""
        If Ps.Exists("GpsLatitudeRef") Then
            Set P = Ps("GpsLatitudeRef")
            LatitudeRéf = P.Value
            Select Case LatitudeRéf
                Case "N"
                    signe = 1
                Case "S"
                    signe = -1
            End Select
            If Ps.Exists("GpsLatitude") Then Latitude = signe * LireAltLatLong(Ps("GpsLatitude"))
        End If
        'Longitude
        LongitudeRéf = ""
        Longtitude = ""
        If Ps.Exists("GpsLongitudeRef") Then
            Set P = Ps("GpsLongitudeRef")
            LongitudeRéf = P.Value
            Select Case LongitudeRéf
                Case "E"
                    signe = 1
                Case "O", "W"
                    signe = -1
            End Select
            If Ps.Exists("GpsLongitude") Then Longitude = signe * LireAltLatLong(Ps("GpsLongitude"))
        End If
        'Auteur
        Auteur = ""
        If Ps.Exists("Artist") Then Auteur = Ps("Artist").Value
        'Date du cliché
        DateCliché = ""
        If Ps.Exists("DateTime") Then DateCliché = Replace(Ps("DateTime"), ":", "/", 1, 2)

        'Orientation de la photo (pour obtenir une orientation correcte de la miniature)
        If Ps.Exists("Orientation") Then
            Select Case Ps("Orientation").Value
                Case 1
                    RotationAngle = 0
                    FlipHorizontal = False
                Case 2
                    RotationAngle = 0
                    FlipHorizontal = True
                Case 3
                    RotationAngle = 180
                    FlipHorizontal = False
                Case 4
                    RotationAngle = 180
                    FlipHorizontal = True
                Case 5
                    RotationAngle = 90
                    FlipHorizontal = False
                Case 6
                    RotationAngle = 90
                    FlipHorizontal = False
                Case 7
                    RotationAngle = 270
                    FlipHorizontal = True
                Case 8
                    RotationAngle = 270
                    FlipHorizontal = False
            End Select
        End If

        'Créer une vignette (100 x 100 maxi)
        'Orientation
        IP.Filters.Add IP.FilterInfos("RotateFlip").FilterID
        IP.Filters(1).Properties("RotationAngle") = RotationAngle
        IP.Filters(1).Properties("FlipHorizontal") = FlipHorizontal
        'Réduction à 100 pixels max (largeur ou hauteur) en gardant les proportions
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        IP.Filters(2).Properties("MaximumHeight") = 100
        IP.Filters(2).Properties("MaximumWidth") = 100
        'Application des transformations via les filtres
        On Error Resume Next
        Set Img = IP.Apply(Img)
        On Error GoTo 0

        'Enregistrement temporaire du fichier miniature (le temps d'importer la miniature)
        CheminTmp = "C:\tmp_img\"
        On Error Resume Next
        MkDir CheminTmp
        Kill CheminTmp & "Thumb" & FiNom
        On Error GoTo 0
        Img.SaveFile CheminTmp & "Thumb" & FiNom

        'Enregistrement des propriétes EXIF à la fin du tableau
        With Lgn
            .Cells(1, 2) = FiRép
            .Cells(1, 3) = FiNom
            .Cells(1, 4) = Auteur
            .Cells(1, 5) = DateCliché
            .Cells(1, 6) = Niveau
            .Cells(1, 7) = Altitude
            .Cells(1, 8) = LatitudeRéf
            .Cells(1, 9) = Latitude
            .Cells(1, 10) = LongitudeRéf
            .Cells(1, 11) = Longitude
        End With

        Set Image = WSh.Shapes.AddPicture(FileName:=CheminTmp & "Thumb" & FiNom, _
        linktofile:=msoFalse, SaveWithdocument:=msoCTrue, _
        Top:=Lgn.Cells(1, 1).Left, Left:=Lgn.Cells(1, 1).Top, Width:=-1, Height:=-1)

        With Image
            'Renommer l'image importée
            .Name = Format(Now, "yyyy:mm:dd_hh:mm:ss")
            Lgn.Cells(1, 1) = .Name
            .Rotation = 0
            'Position (bis) sur le coin sup gauche de la 1ère cellule de la ligne (+1 pour être dans la cellule)
            .Left = Lgn.Cells(1, 1).Left + 1
            .Top = Lgn.Cells(1, 1).Top + 1
            'Conserver le ratio H/L avant le redimensionnement
            .LockAspectRatio = msoTrue
            'Réglage de la hauteur (= hauteur de la ligne -2)
            .Height = Lgn.Cells(1, 1).Height - 2
            'Texte de remplacement
            .AlternativeText = ""
            'Associer à la macro "MontrerPhoto" (via clic)
            .OnAction = "MontrerPhoto"
        End With

        'Supprimer le fichier miniature temporaire
        Kill CheminTmp & "Thumb" & FiNom
        '     FiChoisi.Close False
        Lgn.Resize(1, 12).VerticalAlignment = xlCenter
    Next i
    With WSh.Range("A3:L" & Lgn.Row).Borders
        .Weight = xlThin
        .LineStyle = xlContinuous
    End With
    Set WSh = Nothing
    Set FSO = Nothing
    Set P = Nothing:     Set Ps = Nothing:     Set IP = Nothing:     Set Img = Nothing:     Set Image = Nothing
End Sub
Le 29/11/2023 à 09:34

Bonjour,

Merci pour votre aide.

Malheureusement ca bloque sur : .Style = "Hyperlink"

Par contre une personne a trouvé et ca marche nickel ci dessous les éléments modifiés :

1) Il ne faut pas utiliser If Dir(FiChoisi) = "" Then Exit Sub mais créer ce bloc :

VB:

If Dir(FiChoisi) <> "" Then
'----
End If

2) Dans ce bloc If/End If supprimer ceci qui crée un bug :

VB:

Set Img = IP.Apply(Img)

3) Dans ce bloc If/End If supprimer à la fin :

VB:

 'Set P = Nothing:     Set Ps = Nothing:     Set IP = Nothing:     Set Img = Nothing:     Set Image = Nothing
     'Set Lgn = Nothing:     Set LO = Nothing:     Set WSh = Nothing
     'Set FSO = Nothing
'     FiChoisi.Close False
'Exit For
Rechercher des sujets similaires à "boucle next macro qui bloque"