Agrandir photos

[fp22us]

Bonjour le forum,
Je solicite votre aide afin de resoudre un probleme d'agrandissement d'image.
J'ai eu beau chercher sur le forum, je n'ai pas trouve de solution.

Voila, j'ai un fichier dans lequel j'ai importe de images qui se trouvent dans la col B.
J'aimerais pouvoir cliquer dessus, et l'agrandir, puis recliquer et la retrecir a nouveau.

J'ai ecrit le code suivant, mais deux problemes se posent (en meme temps je suis pas tres doue en vba ...):
1. Quand je double doubleclique sur l'image, la macro ne s'execute pas. Par contre j'ai la fenetre de propriete de l'image qui apparait.
2. Si je double clique ailleurs, la macro s'execute en agrandissant la photo. Par contre elle ne se retrecit pas.


Si quelqu'in pouvait jeter un coup d'oeil, se serait tres sypma.

Merci d'avance.

Fp22us


Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


i = Target.Row
Set Plg = Cells(i, 2)
For Each shp In ActiveSheet.Shapes
shp.Select
shapeW = Selection.ShapeRange.Width
MsgBox shapeW
If shapeW = 84 Then
Selection.ShapeRange.ScaleWidth 3, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 3, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ZOrder msoBringToFront
Else:
MsgBox shapeW
Selection.ShapeRange.ScaleWidth 0.33, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.33, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ZOrder msoSendToBack
End If
End If
Next shp

End Sub

 

[mutzik]

Re : Agrandir photos

bonjour,
ton code est, pour le moment associé au double click sur ta feuille, c'est donc normal que rien ne se passe quand tu cliques sur l'image

mets ton code dans un module ,et associe ce code à ton image et cela devrait le faire
sinon, mets ton fichier en pj

 

[fp22us]

Re : Agrandir photos

Salut Mutzik,
En fait comme j'ai plusieurs photos dans ma colonne B, je ne peux donc pas y associer manuellement de macro, le nombre de photos en colonne B etant variable.

Je joins un fichier, avec deux photos inserees en B15 et B19.
Si je double clic en dans une cellule de la ligne 19, la macro se lance comme explique precedemment.
Par contre si je double clic en sur une cellule de la ligne 15 rien ne se passe (contre toute attente ?)

Merci d'avance de ton aide.

 

[job75]

Re : Agrandir photos

Bonjour,

Un essai avec ce fichier et cette macro :

Sub ChangeDimensions()
ThisWorkbook.Names.Add "K", IIf([K] = 2, 0.5, 2)
Nom = Application.Caller
With ActiveSheet.Shapes(Nom)
.Width = [K] * .Width
.Height = [K] * .Height
End With
End Sub

K est un nom créé dans le fichier.

A+

 

[fp22us]

Re : Agrandir photos

Merci Job,
Elle est bien ta macro, (meme si je dois avouer ne pas avoir bien compris comment elle marche).

Cela dit, je suis oblige de l'assigner manuellement a la photo que je veux agrandir.

Il y a t'il un moyen de parvenir au meme resultat sans les assigner manuellement?

Merci encore

 

[job75]

Re : Agrandir photos

Re,

Désolé fp22us, je m'étais absenté.

Votre fichier et les macros qui fonctionnent pour toutes les Shapes du classeur.

Pour leur affecter la macro ChangeDimensions, appuyer d'abord sur les touches Ctrl+A.

Sub AffecterMacro() 'peut se lancer par Ctrl+A
Dim s As Shape
For Each s In ActiveSheet.Shapes
s.OnAction = "ChangeDimensions"
Next
End Sub

Sub ChangeDimensions()
Dim Nom$, coef As Double
On Error Resume Next
Nom = "X" & Application.Caller 'les noms doivent commencer par une lettre...
coef = Mid(ThisWorkbook.Names(Nom), 2, 20) 'élimine le caractère =
If Err Then coef = 2 Else coef = 1 / coef 'coef 2 pour l'agrandissement
ThisWorkbook.Names.Add Nom, coef
With ActiveSheet.Shapes(Application.Caller)
.Width = .Width * coef
.Height = .Height * coef
End With
End Sub

Edit : enregistrer d'abord le fichier sur le bureau.

A+

 

[job75]

Re : Agrandir photos

Re,

Il y avait un problème pour les variables coef décimales (histoire de séparateur).

J'ai modifié la macro :

Sub ChangeDimensions()
Dim Nom$, coef As [COLOR="Red"]Variant[/COLOR]
On Error Resume Next
Nom = "X" & Application.Caller 'les noms doivent commencer par une lettre...
[COLOR="Red"]coef = Evaluate(Nom)[/COLOR]
If [COLOR="Red"]IsError(coef)[/COLOR] Then coef = [COLOR="Red"][B]1.8[/B][/COLOR] Else coef = 1 / coef 'coef 1,8 pour l'agrandissement
ThisWorkbook.Names.Add Nom, coef
With ActiveSheet.Shapes(Application.Caller)
.Width = .Width * coef
.Height = .Height * coef
End With
Application.OnRepeat "", "" 'évite "Répéter Macros" menu Edition
End Sub

A+

 

[fp22us]

Re : Agrandir photos

Bravo Job75,

C'est extraordinaire. Ca roule tout seul.
Merci, c'est vraiment genial!!!!!!!
Et pour le coup, je suis carrement impressionne.

Fp22us

 

[job75]

Re : Agrandir photos

Bonjour le fil,

Un détail (de peu d'importance) sur ces photos :

- clic droit sur une photo => Format de l'image => Dimension

- les cases Proportionnel et Proportionnelle à l'image d'origine sont cochées

- de ce fait la macro applique 2 fois la variable coef donc 1.8 x 1.8 = 3.24

- si l'on veut strictement 1.8 décocher les 2 cases.

A+

 

[job75]

Re : Agrandir photos

Re,

En utilisant la propriété LockAspectRatio on s'assure que c'est toujours le coefficient inscrit dans la macro qui est appliqué :

Sub ChangeDimensions()
Dim Nom$, coef As Variant
On Error Resume Next
Nom = "X" & Application.Caller 'les noms doivent commencer par une lettre...
coef = Evaluate(Nom)
If IsError(coef) Then coef = [COLOR="Red"]3.5[/COLOR] Else coef = 1 / coef 'coef 3,5 pour l'agrandissement
ThisWorkbook.Names.Add Nom, coef
With ActiveSheet.Shapes(Application.Caller)
[COLOR="Red"].LockAspectRatio = msoFalse[/COLOR]
.Width = .Width * coef
.Height = .Height * coef
End With
Application.OnRepeat "", "" 'évite "Répéter Macros" menu Edition
End Sub

A+

 

[fp22us]

Re : Agrandir photos

ok, je ne fais pas avancer le fil,
mais un grand merci a Job75 pour son aide.

Merci donc.

Fp22us

 

[gilles03]

Re : Agrandir photos

Bonjour tous
je voudrais me faire un fichier de mes cartes postales.J'ai regarde avec attention les explications de job75 pour agrandir une photo,j'ai essayer d'appliquer ces codes sur mon appli mais ça ne marche pas .J'ai donc essayer d'enlever la premiere chaussure et de la remplacer par une photo, toujours pareil a chaque fois je clic ça double l'image. (contrairement a la photo de la chaussure en dessous)quelqu'un pourait il me dire pourquoi
D'avance merci Gilles03


d'Avance merci

 

[job75]

Re : Agrandir photos

Bonjour gilles03,

Désolé, je n'avais pas vu votre post, merci pour le MP.

Le nom de votre objet "Image 17" comprend un espace et du coup le nom défini "Nom" ne peut pas être créé.

J'ai donc modifié la 4ème ligne de la macro :

Nom = "X" & [COLOR="Red"]Replace([/COLOR]Application.Caller[COLOR="red"], " ", "_")[/COLOR] 'les noms doivent commencer par une lettre...

L'espace est remplacé par le tiret bas _

Votre fichier corrigé joint.

A+

 

[gilles03]

Re : Agrandir photos

Re

Merci Beaucoup c'est vraiment Sympa

Gilles

 

[gilles03]

Re : Agrandir photos

Re

j'espere ne pas trop vous embeter.Je croyais avoir compris qu'il faut que le nom de mon image commence par une lettre.Par contre je ne vois pas ou je donne ce nom.Lorsque je suis sur la photo je clic dans proprietée si je donne le nom de chateau_14 par exp ce n'est par pour ça que ça ouvre

Merci Gilles
Regarde la pièce jointe Essais collection 2.zip