Discussion :

[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 .

[Invité]

Bonjour,

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
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

[diss10]

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 :

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
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 :

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

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

[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!

Pourquoi le test() ?

pour faire un test!

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!

Code :

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

Sub redimm()

c'est domage de nommer un sub par le nom d'une fonction qui existe dans vba!

[diss10]

Question rapide :

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

MERCI BCP

[Invité]

Désolé volà qui est mieux!

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
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

[Invité]

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 :

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
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

[diss10]

Ç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 :

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

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

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 :

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
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 .

[Invité]

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
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

[diss10]

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
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))

[Invité]

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
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