Discussion :

[kent010]

Bonjours, je désire créer une Macro pour redimensionner une image en gardant ses proportion. Pour cela j'utilise la fonction iPict afin de connaitre sa taille (Height & Width) en CM.
Puis je fait un calcul pour savoir par combien je doit multiplier mon image pour obtenir la taille voulut et je la redimensionne.
Pour faire cela j'utilise le code suivant:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
 
Sub DimensionsImage()
  'Fonctionne pour les formats: JPG, jpeg, gif, bmp
 
'Recupere la taille d'un image sur le disque dur
 
    Dim iPict As IPictureDisp
    Dim NomFichier As String
 
    Chemin = Application.GetOpenFilename(, , "Choisissez le LOGO")
 
 If Chemin <> False Then
            Else
            Exit Sub
        End If
 
    Set iPict = LoadPicture(Chemin)
    Largeur = Round((iPict.Width) / 1000, 2)
    Hauteur = Round((iPict.Height) / 1000, 2)
 
'MsgBox "Largeur:" & Largeur & " Hauteur:" & Hauteur
 
'Calcul le % par rapport a la taille voulut et garde le plus petit puis effectue la modification sur l'image
 
 
 
    If (8.48 / Largeur) < (5.31 / Hauteur) Then
        Pourcentage = (8.48 / Largeur)
        Info = "Largeur"
        Else
            Pourcentage = (5.31 / Hauteur)
            Info = "Hauteur"
    End If
 
 
'MsgBox Pourcentage & Info
 
' Insert et redimentionne l'image
 
    Range("S16").Select
    ActiveSheet.Pictures.Insert(Chemin).Select
    Selection.ShapeRange.ScaleHeight Pourcentage, msoFalse, msoScaleFromTopLeft
 
' Centre l'image
    If Info = "Largeur" Then
        Decallage = ((5.31 - (Hauteur * Pourcentage)) / 2) * 28.35
        Selection.ShapeRange.IncrementTop Decallage
        Else
            Decallage = ((8.48 - (Largeur * Pourcentage)) / 2) * 28.35
            Selection.ShapeRange.IncrementLeft Decallage
    End If
 
End Sub

1) Le problème survient lors se que je sélectionne des images d'une définition différente de 96ppp. La fonction iPict ne me retourne plus la bonne valeur.
2) Le problème se pose aussi si je sélectionne une image trop grande car au moment de l'insertion de l’image sur excel celle ci est automatiquement redimensionner. La ligne de code (42) qui retaille mon image est donc erroné car elle fonctionne uniquement pour une image a 100% de sa taille.

Je cherche donc:
1)Une fonction pour me donner la définition de l'image ou autre solution.
2)A empêcher le redimensionnement de l'image lors de son insertion.

Merci de votre lecture et attention.
PS: Désolé pour l’orthographe.

[kiki29]

Salut,regarde dans la FAQ.
il y a

.LockAspectRatio = msoFalse

à basculer en

msoTrue

Sinon 96 ppp veut dire 96 points pour 2.54 cm ( 1 pouce )

[patricktoulon]

Bonjour
Ce que tu cherche a faire existe deja
Fait une recherche dans les contributions
J'avais fait ca il y a au moins deux ans pour reduire le poid de es photos en haute qualité. Mon app photo rendais des photos. Acec un poid de 15mega parfois
Fat une recherche dans les contributions avec pour indice(photo resize)
Bonne continuation

[kent010]

Merci KIKI29 pour ta réponse cependant ta réponse ne correspond pas hélas a ma question.
J'arrive parfaitement a ne pas écraser l'image (garder ses proportion). Ce que je ne parviens pas a faire c redimensionner l'image en fonction de sa définition. C'est pourquoi il me faudrait une fonction permettant de récupérer la définition de l'image directement.
PS: merci pour le 96ppp = 2.54 cm. Cela explique certaine chose ^^

Merci patricktoulon, je vais regarder dans les contributions en espérant trouver ma solution.