Compression des photos a l'insertion sur mon fichier

Version imprimable

01/08/2016, 09h20
diss10

Compression des photos a l'insertion sur mon fichier

Bonjour les amis :)

Je voudrais savoir s'il est possible d'avoir une macro qui compresse les photo que je vai insérer dans mon ficher excel (J'ai beaucoup de photo a chaque dans chaque fenêtre) .
Ca va bcp m'aider avec un bouton qui permet d’insérer les photos et de les compresser avant :)

Merci beaucoup .

:)

Bonjour,

Code:

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
Private Function redimensionnerImage(Fichier As String)
On Error GoTo 0
Dim Img As New WIA.ImageFile, IP As New WIA.ImageProcess
     Set Img = CreateObject("WIA.ImageFile")
    'Set IP = CreateObject("WIA.ImageProcess")
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    'Set IP = CreateObject("WIA.ImageProcess")
 
    'Chargement de l'image dans le conteneur
    Img.LoadFile Fichier
 
        'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = 90
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = 90
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
 
    'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    If Dir(Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)) <> "" Then Kill Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    Img.SaveFile Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    redimensionnerImage = Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
End Function
Sub test()
redimensionnerImage "C:\Documents and Settings\All Users\Documents\Mes images\Échantillons d'images\Collines.jpg"
End Sub

Fonctionnement

Merci beaucoup , j'ai un souci car je n'arrive pas a l'affecter a mon bouton . Peut être que je doit déclarer la macro ?

Code:

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
Sub redimm()
Dim Img As New WIA.ImageFile, IP As New WIA.ImageProcess
     Set Img = CreateObject("WIA.ImageFile")
    'Set IP = CreateObject("WIA.ImageProcess")
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    'Set IP = CreateObject("WIA.ImageProcess")
 
    'Chargement de l'image dans le conteneur
    Img.LoadFile Fichier
 
        'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = 90
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = 90
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
 
    'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    If Dir(Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)) <> "" Then Kill Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    Img.SaveFile Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    redimensionnerImage = Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
End Sub

Mais ça ne marche pas qd j'affecte .

Pour :

Code:

1
2
3
Sub test()
redimensionnerImage "C:\Documents and Settings\All Users\Documents\Mes images\Échantillons d'images\Collines.jpg"
End Sub

Pourquoi le test() ?

MERCII :)

01/08/2016, 11h00
Invité

ici nous avons un fonction qui qui compact limage à 10%! elle retourne le nom de limage ainsi compacté.

tu n'as pas à modififer le nom de la fonction et c'est elle que tu appel!

Citation:

Pourquoi le test() ?

pour faire un test!

Citation:

j'ai un souci car je n'arrive pas a l'affecter a mon bouton . Peut être que je doit déclarer la macro ?

disons que sub test c'est la macro de ton bouton!

Citation:

Code:

Sub redimm()

c'est domage de nommer un sub par le nom d'une fonction qui existe dans vba!
01/08/2016, 11h33
diss10

1 pièce(s) jointe(s)

erreur

Question rapide :

Comment appeler une Function , est-ce comme appeler une Sub ?

MERCI BCP

Désolé volà qui est mieux!

Code:

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
Function redimensionnerImage(Fichier As String)
On Error GoTo 0
 
Dim Img As Object, IP As Object
'Dim Img As New WIA.ImageFile, IP As New WIA.ImageProcess
     Set Img = CreateObject("WIA.ImageFile")
    'Set IP = CreateObject("WIA.ImageProcess")
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    'Set IP = CreateObject("WIA.ImageProcess")
 
    'Chargement de l'image dans le conteneur
    Img.LoadFile Fichier
 
        'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = 90
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = 90
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
 
    'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    If Dir(Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)) <> "" Then Kill Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    Img.SaveFile Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    redimensionnerImage = Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
End Function

01/08/2016, 12h32
diss10

1 pièce(s) jointe(s)

COMMENT APPELER LA FUNCTION ?

Pièce jointe 216936

J'ai une erreur de compilation "fichier" ?

Merci bcp
01/08/2016, 12h38
Invité
place le code que tu utilisais pour inserrer une image dans ton fichier Excel et je te dirrais comment modifier ton code!

car cette parti là ne change pas ce juste le nom du fichier qui change!
Code:

1 2 3 Sub test() NomDuFichierImage= redimensionnerImage("C:\Documents and Settings\All Users\Documents\Mes images\Échantillons d'images\Collines.jpg") End Sub

Citation:

Envoyé par rdurupt

place le code que tu utilisais pour inserrer une image dans ton fichier Excel

Voila mon code maintenant , mais j'ai un problème pendant la compilation au niveau de " img.load fichier"

Code:

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
Function redimensionnerImage(Fichier As String)
On Error GoTo 0
 
Dim Img As Object, IP As Object
'Dim Img As New WIA.ImageFile, IP As New WIA.ImageProcess
     Set Img = CreateObject("WIA.ImageFile")
    'Set IP = CreateObject("WIA.ImageProcess")
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    'Set IP = CreateObject("WIA.ImageProcess")
 
    'Chargement de l'image dans le conteneur
    Img.LoadFile Fichier
 
        'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = 90
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = 90
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
 
    'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    If Dir(Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)) <> "" Then Kill Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    Img.SaveFile Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    redimensionnerImage = Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
End Function
 
Sub test()
NomDuFichierImage = redimensionnerImage("C:\Documents and Settings\All Users\Documents\Mes images\Échantillons d'images\Collines.jpg")
End Sub

Mercii :)

Citation:

Envoyé par diss10

Bonjour les amis :)

Je voudrais savoir s'il est possible d'avoir une macro qui compresse les photo que je vai insérer dans mon ficher excel (J'ai beaucoup de photo a chaque dans chaque fenêtre) .
Ca va bcp m'aider avec un bouton qui permet d’insérer les photos et de les compresser avant :)

Merci beaucoup .

:)

là tu me redonne le code que je t'es fourni pour la conversion, mais toi de ton coté tu n'avais pas un code qui insert un photo non compressé?

Code:

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
Sub Macro1()
'
' Macro1 Macro
'
 
'
    ActiveSheet.Pictures.Insert redimensionnerImage("C:\Users\Public\Pictures\Sample Pictures\Desert.jpg")
End Sub
Function redimensionnerImage(Fichier As String)
On Error GoTo 0
 
Dim Img As Object, IP As Object
'Dim Img As New WIA.ImageFile, IP As New WIA.ImageProcess
     Set Img = CreateObject("WIA.ImageFile")
    'Set IP = CreateObject("WIA.ImageProcess")
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    Set IP = CreateObject("WIA.ImageProcess")
 
    'Chargement de l'image dans le conteneur
    Img.LoadFile Fichier
 
        'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = 90
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = 90
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
 
    'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    If Dir(Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)) <> "" Then Kill Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    Img.SaveFile Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    redimensionnerImage = Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
End Function

Ça marche la macro pour le fichier Test () , j'ai l'image qui s'insère directement .

Ce que je voudrais c pouvoir sélectionner moi mêmes l'image en cliquant sur le bouton que j'ai créer . Comme pour l'insertion d'image sous excel (ouvrir et choisir mon image )

voila la macro pour insérer l'image ou les images non compressé :
Code:

1 2 3 4 5 6 7 8 9 10 Sub insérerimage() ' ' insérerimage Macro ' insertionimage ' ' ActiveSheet.Pictures.Insert("C:\Users\I1181859\Desktop\20160711_111029.jpg"). _ Select End Sub
Sauf que je voudrais sélectionner moi mêmes les photos a insérer et comprésser .

Merci :)

Citation:

Envoyé par rdurupt

là tu me redonne le code que je t'es fourni pour la conversion, mais toi de ton coté tu n'avais pas un code qui insert un photo non compressé?
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Public Sub insere_image() Dim ficimg As Variant ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix nom du fichier ActiveSheet.Pictures.Insert(ficimg).Select ' insertion With Selection.ShapeRange .LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez .Top = ActiveCell.Top ' haut de la cellule .Left = ActiveCell.Left ' gauche de la cellule .Height = ActiveCell.RowHeight ' hauteur de la cellule .Width = ActiveCell.Width ' largeur de la cellule End With With Selection .PrintObject = True ' l'objet est imprimé en même temps que le document .Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules End With End Sub
Comment je peut l'adapter pour insérer les images + la compression ?

Merci bcp .

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Public Sub insere_image()
Dim ficimg As Variant
    ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")  ' choix nom du fichier
    ActiveSheet.Pictures.Insert(redimensionnerImage(ficimg)).Select ' insertion
    With Selection.ShapeRange
        .LockAspectRatio = False        ' proportions d'origine lorsque vous la redimensionnez
        .Top = ActiveCell.Top           ' haut de la cellule
        .Left = ActiveCell.Left         ' gauche de la cellule
        .Height = ActiveCell.RowHeight  ' hauteur de la cellule
        .Width = ActiveCell.Width ' largeur de la cellule
    End With
    With Selection
        .PrintObject = True             ' l'objet est imprimé en même temps que le document
        .Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules
    End With
End Sub

Code:

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
Function redimensionnerImage(Fichier As String)
On Error GoTo 0
 
 
Public Sub insere_image()
Dim ficimg As Variant
Dim Img As Object, IP As Object
 
    ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")  ' choix nom du fichier
    ActiveSheet.Pictures.Insert(redimensionnerImage(ficimg)).Select ' insertion
    With Selection.ShapeRange
        .LockAspectRatio = False        ' proportions d'origine lorsque vous la redimensionnez
        .Top = ActiveCell.Top           ' haut de la cellule
        .Left = ActiveCell.Left         ' gauche de la cellule
        .Height = ActiveCell.RowHeight  ' hauteur de la cellule
        .Width = ActiveCell.Width ' largeur de la cellule
    End With
    With Selection
        .PrintObject = True             ' l'objet est imprimé en même temps que le document
        .Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules
    End With
 
    Set Img = CreateObject("WIA.ImageFile")
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    Set IP = CreateObject("WIA.ImageProcess")
 
    'Chargement de l'image dans le conteneur
    Img.LoadFile Fichier
 
        'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = 90
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = 90
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
 
    'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    If Dir(Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)) <> "" Then Kill Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    Img.SaveFile Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    redimensionnerImage = Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
End Function
 
End Sub

J'ai une erreur au niveau de (redimensionnerImage(ficimg)) :(

Code:

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
Function redimensionnerImage(Fichier As String)
On Error GoTo 0
 
 
Public Sub insere_image()
Dim ficimg As Variant
Dim Img As Object, IP As Object
 
    ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")  ' choix nom du fichier
    ActiveSheet.Pictures.Insert(redimensionnerImage(Cstr(ficimg))).Select ' insertion
    With Selection.ShapeRange
        .LockAspectRatio = False        ' proportions d'origine lorsque vous la redimensionnez
        .Top = ActiveCell.Top           ' haut de la cellule
        .Left = ActiveCell.Left         ' gauche de la cellule
        .Height = ActiveCell.RowHeight  ' hauteur de la cellule
        .Width = ActiveCell.Width ' largeur de la cellule
    End With
    With Selection
        .PrintObject = True             ' l'objet est imprimé en même temps que le document
        .Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules
    End With
 
    Set Img = CreateObject("WIA.ImageFile")
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    Set IP = CreateObject("WIA.ImageProcess")
 
    'Chargement de l'image dans le conteneur
    Img.LoadFile Fichier
 
        'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = 90
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = 90
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
 
    'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    If Dir(Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)) <> "" Then Kill Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    Img.SaveFile Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    redimensionnerImage = Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
End Function
 
End Sub

01/08/2016, 21h06
diss10

1 pièce(s) jointe(s)

Pièce jointe 216966

J'ai cette erreur d’exécution :(

j'avais pas fais gaff tu as fait un cocktail des 2 codes'

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Public Sub insere_image()
Dim ficimg As Variant
    ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")  ' choix nom du fichier
    ActiveSheet.Pictures.Insert(redimensionnerImage(Cstr(ficimg))).Select ' insertion
    With Selection.ShapeRange
        .LockAspectRatio = False        ' proportions d'origine lorsque vous la redimensionnez
        .Top = ActiveCell.Top           ' haut de la cellule
        .Left = ActiveCell.Left         ' gauche de la cellule
        .Height = ActiveCell.RowHeight  ' hauteur de la cellule
        .Width = ActiveCell.Width ' largeur de la cellule
    End With
    With Selection
        .PrintObject = True             ' l'objet est imprimé en même temps que le document
        .Placement = xlMoveAndSize      ' manière dont l'objet est lié aux cellules
    End With
End Sub

Code:

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
 
Function redimensionnerImage(Fichier As String)
On Error GoTo 0
 
Dim Img As Object, IP As Object
'Dim Img As New WIA.ImageFile, IP As New WIA.ImageProcess
     Set Img = CreateObject("WIA.ImageFile")
    'Set IP = CreateObject("WIA.ImageProcess")
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    Set IP = CreateObject("WIA.ImageProcess")
 
    'Chargement de l'image dans le conteneur
    Img.LoadFile Fichier
 
        'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = 90
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = 90
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
 
    'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    If Dir(Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)) <> "" Then Kill Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    Img.SaveFile Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
    redimensionnerImage = Split(Fichier, ".")(0) & "_2_." & Split(Fichier, ".")(1)
End Function

01/08/2016, 21h28
diss10

Ça maarche :mouarf:

Merci bcp