Redimentionner une photo via VBA

[Fab117]

Salut,
J'avais fait une super macro dans Excel 2003 qui après avoir mis une photo dans une cellule redimentionnait la photo.
Le code était :
LigneOuCollerLaPhoto = 7
For i = 1 To NombreDeLigneTotale
Cells(LigneOuCollerLaPhoto, 1).Select
NomDeLaPhoto = Cells(LigneOuCollerLaPhoto, 1)

' Va chercher la photo dans le répertoire ...\TmpPhotosMiniatures
CheminDAccesAuxPhotos = ThisWorkbook.Path & "\TmpPhotosMiniatures\"
' Insère la photo dans la cellule selectionnée
ActiveSheet.Pictures.Insert( _
CheminDAccesAuxPhotos & NomDeLaPhoto). _
Select ' Le nom de la photo est malheureusement définie
' Redimentionnement de la photo
Selection.ShapeRange.ScaleWidth 0.48, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.48, msoFalse, msoScaleFromTopLeft

LigneOuCollerLaPhoto = LigneOuCollerLaPhoto + 3
Next i
Je suis passé à Excel 2007 et avec le même code, il insère toutes les photos les unes sur les autres (hors cellule) en tailles trop petites.
J'ai essayé via l'éditeur de macro d'enregistrer le redimentionnement d'une photo, mais il n'enregistre pas ces opérations.

Quelqu'un saurait-il pourquoi ça ne fonctionne plus et surtout comment remédier ?

Merci d'avance.

Fab

 

[Fab117]

Re : Redimentionner une photo via VBA

Salut,
J'ai un nouveau problème avec cette macro.
Il va bien chercher toutes les photos dans le répertoire ciblé et il les insère correctement redimensionnées dans Excel.
Mais ... il les prend dans l'ordre alphabétique inverse.
J'imagine que c'est plus dans Windows que dans Excel qu'il faut corriger, mais je vois pas du tout.
Est-il possible de préciser dans la macro qu'il prenne les photo dans l'ordre alphabétique ?
Merci d'avance et bonne soirée.

Fab

 

[Guest]

Re : Redimentionner une photo via VBA

Bonsoir,

Je suppose qu'il affiche les fichiers l'ordre dans lequel ils sont affichés par l'explorateur windows et les paramètres d'affichage du dossier. A vérifier.

Sinon, il faudrait réécrire la macro.
Mettre les noms dans un tableau à 1 dimension, le trier et appeler les fichiers 1 à 1 à partir de ce tableau.

A+

 

[Fab117]

Re : Redimentionner une photo via VBA

Salut,
Merci pour ton suivi.
J'ai fait une multitude d'essais dans Windows, mais je ne comprend pas la logique d'Excel dans l'insertion des photos => j'ai tout retravaillé.
1) il compte le nombre de photo dans le répertoire cible
NombreDeLigneAInserer = fol.Files.Count
2) Il rajoute les lignes manquantes
3) Il inscrit les noms des fichiers dans chaque cellule
For Each fil In fol.Files
Cells(LigneOuCollerLaPhoto, 1).Select
Cells(LigneOuCollerLaPhoto, 1) = fil.Name
LigneOuCollerLaPhoto = LigneOuCollerLaPhoto + 3
Next
4) Il reclasse par ordre alphabétique
Range("A7:B" & (NombreDeLigneAInserer * 3) + 7).Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
5) Dans chaque cellule il récupère le nom inscrit et va chercher la photo correspondant (puis il la redimentionne)

Tout va bien jusqu'au point 5 où il selectionne bien la bonne cellule, récupère bien le bon nom, va bien chercher la bonne photo, mais ... il l'insère dans la mauvaise cellule. En fait, il les insère toute en "A7".

Voici le code de cette partie :
LigneOuCollerLaPhoto = 7
For i = 1 To NombreDeLigneAInserer
Range("A" & LigneOuCollerLaPhoto).Select
NomDeLaPhoto = Cells(LigneOuCollerLaPhoto, 1)
Set oImage = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\TmpPhotosMiniatures\" & NomDeLaPhoto)
With oImage
With .ShapeRange
.LockAspectRatio = msoTrue
.Top = Range("A7").Top
.Left = Range("A7").Left
If .Width > Range("A7").Resize(3, 2).Width Then .Width = Range("A7").Resize(3, 2).Width
If .Height > Range("A7").Resize(3, 2).Height Then .Height = Range("A7").Resize(3, 2).Height
End With
End With
LigneOuCollerLaPhoto = LigneOuCollerLaPhoto + 3
Next i

Sais-tu pourquoi il ne veut pas faire l'insertion en Range("A" & LigneOuCollerLaPhoto) ?

Merci d'avance.

Fab

 

[Fab117]

Re : Redimentionner une photo via VBA

Mais c'est bien sur.
Avec :
.Top = Range("A" & LigneOuCollerLaPhoto).Top
.Left = Range("A" & LigneOuCollerLaPhoto).Left
If .Width > Range("A" & LigneOuCollerLaPhoto).Resize(3, 2).Width Then .Width = Range("A" & LigneOuCollerLaPhoto).Resize(3, 2).Width
If .Height > Range("A" & LigneOuCollerLaPhoto).Resize(3, 2).Height Then .Height = Range("A" & LigneOuCollerLaPhoto).Resize(3, 2).Height

Ca va tout de suite mieux.

Merci encore et bon week-end