Boucle For Next macro excel qui bloque
Résolualea83500 Messages postés 18 Date d'inscription Statut Membre Dernière intervention -
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
- Boucle For Next macro excel qui bloque
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Downloader for pc - Télécharger - Téléchargement & Transfert
- Liste déroulante excel - Guide
- Code puk bloqué - Guide
- Word et excel gratuit - Guide
7 réponses
Bonjour,
C'est bon une personne a trouvé le souci et maintenant ca marche enfin..
Merci pour votre aide.
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
Bonjour,
Un fichier serait mieux que ce code
Pour transmettre un fichier,
Veillez a ce qu'il n'y ait PAS DE DONNEES CONFIDENTIELLES
il faut passer par un site de pièce jointe tel que cjoint.com
Allez sur ce site : http://cjoint.com
Clic sur parcourir,
Cherche ton fichier,
clic sur ouvrir,
Clic sur "Créer le lien cjoint",
Copier le lien,
Revenir ici le coller dans une réponse...
bonjour,
Et si tu supprimes la ligne sur laquelle le code s'arrête?
BOnjour,
Merci pour votre réponse, ci dessous le lien.
En fait le code fonctionnait trés bien quand le chemin était complet : ThisWorkbook.Path & "\PHOTOS\1.jpg"
J'ai juste rajouté : Dim i As Integer
i = 1
For i = i To 700 et mis i à la place de 1 dans le chemin et Next à la fin et cela ne fonctionne plus.
Oui j'ai essayé d'enlever la ligne de code ou ca bloquait et aprés ca bloque ailleurs.
Je me demande si cela ne viendrait pas du temps d'affichage à la fin du code ?
Merci encore pour votre aide, mon niveau étant trop faible.
https://www.cjoint.com/c/MKBio2vTVbA
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionBonjour,
c'est i=1, ce n'est pas bon ?
Bonjour,
Je récupère votre fichier et regarde la chose
Suite:
Les noms de fichier sont des chaines de carateres meme si un ou plusieurs chiffres sont dans le dit nom
For i = 1 To 700
FiChoisi = ThisWorkbook.Path & "\PHOTOS\" & CStr(i) & ".jpg"
'InitialFileName = (ThisWorkbook.Path & "\PHOTOS\1.jpg")
If FiChoisi = "" Then Exit Sub
Bonjour,
Une personne a trouvé ce qui n'allait pas.
Merci encore pour votre aide.
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