redimensionner une image

Version imprimable

Voir 40 message(s) de cette discussion en une page

04/02/2012, 15h33
hottis

redimensionner une image

Bonour
voilà mon problème , j'ai un classeur excel qui contient de multiples onglets ( c'est variable entre 10 et 30 à peu près ), je dois changer un logo A( image .jpg ) par un logo B ( aussi une image .jpg ) sur chaque onglet, le souci est que d'un onglet à l'autre le positionnement du logo A n'est pas le même ainsi que la taille du logo, ce qui veut dire que lorsque je remplace le logo A par le logo B, un coup il est bien centré par rapport à l'origine ou bien il est décentré et trop petit ou trop grand, avez vous une solution pour ça ??

Bonjour,

Bienvenue sur le forum.

Pour remplacer un logo A par un logo B sur toutes les feuilles du classeur, en conservant la taille et position spécifique sur chaque feuille du logo A.

Code:

1
2
3
4
5
6
7
Private Sub CommandButton1_Click()
    Dim ws As Worksheet
 
    For Each ws In Worksheets
        Call LoadPict(ws, "LogoA", "C:\Documents and Settings\My Documents\Images\LogoB.jpg")
    Next ws
End Sub

Vérifie qu'il y a bien une image sur la feuille.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Private Function DoesPictExist(ws As Worksheet, PictName As String) As Boolean
    DoesPictExist = False
 
    Dim p As Object
    For Each p In ws.Pictures
        If p.Name = PictName Then
            DoesPictExist = True
            Exit For
        End If
    Next p
End Function

Supprime l'image existante, et la remplace par l'image contenu dans le fichier "filename", en conservant la taille et position de l'image précédente.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Private Sub LoadPict(ws As Worksheet, PictName As String, filename As String)
    Dim l As Integer, t As Integer, w As Integer, h As Integer
 
    If DoesPictExist(ws, PictName) Then
        With ws.Pictures(PictName)
            l = .Left
            t = .Top
            w = .Width
            h = .Height
            .Delete
        End With
 
       With ws.Pictures.Insert(filename)
           .Name = PictName
           .Left = l
           .Top = t
           .Width = w
           .Height = h
       End With
 
    End If
 
End Sub

Ce code est basé sur le principe que l'image et nommée.
Mais en appelant la propriété Pictures(<index de l'image>)

Bonjour,

En MP vous vous privez du support et avis de tous les membres du forum.
Le mieux est toujours de poster vos questions techniques sur le forum.
(Et en général les MP Technique finissent :zekill:)
Merci de votre compréhension.
Citation:
Envoyé par hottis
Bonjour

pour infos voilà ce que j'avais fait, ça fonctionnait plutôt bien , mise à part la taille des images insérer (logo B) ne respectait pas la taille initiale du logo A.

'suppression du logo A
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Application.ScreenUpdating = False For i = 1 To Sheets.Count Sheets(i).Activate Dim Obj As shape Dim Plage As Range, PlageDonnees As Range 'plage de cellules cible Set PlageDonnees = Range("a1:f4") For Each Obj In ActiveSheet.Shapes 'Position du Shape dans la feuille Set Plage = Range(Obj.TopLeftCell.Address & ":" & _ Obj.BottomRightCell.Address) If Not Intersect(Plage, PlageDonnees) Is Nothing Then _ Obj.Delete Next Obj Next i
'insertion du logo B
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Application.ScreenUpdating = False For i = 1 To Sheets.Count Sheets(i).Activate Range("a2").Select ActiveSheet.Pictures.Insert( _ "C:\Users\logo B.jpg" _ ).Select Selection.shaperange.ScaleWidth 0.88, msoFalse, msoScaleFromTopLeft Selection.shaperange.ScaleHeight 0.88, msoFalse, msoScaleFromTopLeft Selection.shaperange.ScaleWidth 0.72, msoFalse, msoScaleFromTopLeft Selection.shaperange.ScaleHeight 0.72, msoFalse, msoScaleFromTopLeft Selection.shaperange.ScaleWidth 0.98, msoFalse, msoScaleFromTopLeft Selection.shaperange.IncrementLeft 18 Selection.shaperange.IncrementLeft -17.25 Selection.shaperange.IncrementTop 1.5 Selection.shaperange.ScaleWidth 1.49, msoFalse, msoScaleFromTopLeft Next i
Ok. pour l'insertion logo B, il reste des "Select/Selection" inutile. (résidu de Macro enregistré).

Pour ce qui est du problème de la taille du logo B ne respectant pas la taille du logo A, la méthode présenté dans le post précédent
indique comment sauvegarder les informations de taille et position du logo A, avant de le supprimer. (voir la fonction LoadPict)

06/02/2012, 11h16
hottis

Bonjour

malheureusement ça ne fonctionne pas avec le code LoadPict

Bonjour,

Citation:

malheureusement ça ne fonctionne pas avec le code LoadPict

Qu'est ce qui ne fonctionne pas ?

Dans cette fonction ,tout n'est peut être pas récupérable.
Ce qui est a garder, au minimum, c'est de récupérer l'emplacement du logo A, avant de le supprimer.
Comme ça tu peut donner les même emplacement au logo B.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Dim l As Integer, t As Integer, w As Integer, h As Integer ' enregistre l'emplacement du logo A, puis le supprime With ws.Pictures(<logo A>) ' ou ws.Pictures(1) s'il n'y a qu'une image dans l'onglet l = .Left t = .Top w = .Width h = .Height .Delete End With ' insert logo B à l'emplacement du logo A With ws.Pictures.Insert(<nom du logo B>) .Left = l .Top = t .Width = w .Height = h End With

06/02/2012, 17h44
hottis

2 pièce(s) jointe(s)

Bonjour

c'est plus compliqué que cela , en effet j'ai bien visuellement une image identique sur chaque onglet, mais la taille change et le nom de l'image n'est pas le même, sur l'onglet 1 je vais avoir une image "picture 50 " , sur l'onglet 2 "picture 12" et ainsi de suite.

Je ne peut donc pas considérer que le nom des images est toujours le même.

En plus je peut avoir plusieurs image sur un onglet , il s'agit de dossier de fabrication , il y a de multiples images sur un onglet

voiçi un exemple d'onglet tel qu'ils peuvent etre dans le fichier

c'est le logo "TES" en haut à gauche qui est à remplacer par un autre

Bonsoir,

Citation:

Je ne peut donc pas considérer que le nom des images est toujours le même.
En plus je peut avoir plusieurs image sur un onglet , il s'agit de dossier de fabrication , il y a de multiples images sur un onglet

Ok, utilisons dans ce cas dénominateur commun l'emplacement de l'image dans la feuille.
Ici la fonction GetLogoPictureName se chargera de trouver le nom de l'image dont le coin haut gauche est à une position inférieure
à une certaine limite.
Code:

1 2 3 4 5 6 7 8 9 Private Function GetLogoPictureName(ws As Worksheet) As String Dim p As Object For Each p In ws.Pictures If (p.Left < 10) And (p.Top < 30) Then GetLogoPictureName = p.Name Exit For End If Next p End Function
La fonction principale devient.
Code:

1 2 3 4 5 6 Private Sub CommandButton1_Click() Dim ws As Worksheet For Each ws In Worksheets Call LoadPict(ws, GetLogoPictureName(ws), "C:\Documents and Settings\My Documents\Images\LogoB.jpg") Next ws End Sub

Bonsoir

sinon il y a cette option qui marche très bien le seul problème c'est qu'il faut cliquer sur l'image pour la remplacer, pour 1 image pourquoi pas mais pour un classeur avec 40 onglets donc 40 images c'est pas le top !!

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
Sub toto()
 
On Error GoTo ErrH:
 
'Declaration of Variables
Dim flag As Boolean
Dim myShape As Shape
Dim cTop As Double
Dim cLeft As Double
Dim cHeight As Double
Dim cWidth As Double
' +-+- Check whether Selection is Shape or Range -+-+
flag = False
For Each myShape In Sheets(i).Activate
    If myShape.Name = Selection.Name Then
        flag = True
        Exit For
    Else
        flag = False
    End If
Next
ErrH:
On Error GoTo endH
' +-+- Checking Over -+-+
If flag = True Then
'Saving Selected Image Attributes
    cTop = Selection.ShapeRange.Top
    cLeft = Selection.ShapeRange.Left
    cHeight = Selection.ShapeRange.Height
    cWidth = Selection.ShapeRange.Width
'Delete Selected Image
    Selection.Delete
 
'Insert New Image
    ActiveSheet.Pictures.Insert(Application.GetOpenFilename).Select
 
'Applying Old attributes to the New image
    Selection.ShapeRange.Top = cTop
    Selection.ShapeRange.Left = cLeft
    Selection.ShapeRange.Height = cHeight
    Selection.ShapeRange.Width = cWidth
Else
    MsgBox "Please select a picture not the range."
End If
endH:
 
End Sub

Une autre approche (plus facile à mettre en oeuvre) c'est d'utiliser des contrôles Images (Contrôle ActiveX) sur chaque feuille que tu nommes Logo

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 RempLogo()
Dim Ws As Worksheet
Dim Image As String
 
Image = "C:\Users\user\Pictures\LogoB.jpg"
If Dir(Image) <> "" Then
    For Each Ws In ThisWorkbook.Worksheets
        If Existe(Ws) Then
            With Ws.OLEObjects("Logo").Object
                .PictureSizeMode = 3
                .Picture = LoadPicture(Image)
            End With
        End If
    Next Ws
End If
End Sub
 
Private Function Existe(ByVal Sh As Worksheet) As Boolean
Dim Obj As OLEObject
 
For Each Obj In Sh.OLEObjects
    If Obj.OLEType = 2 Then
        If Obj.Name = "Logo" Then
            Existe = True
            Exit For
        End If
    End If
Next Obj
End Function

07/02/2012, 08h13
hottis

1 pièce(s) jointe(s)

Bonjour

j'ai le code suivant pour la private function

je ne vois pas trop!!!

avec la piece jointe c'est mieux !
07/02/2012, 10h29
BlueMonkey

Bonjour,

Citation:

j'ai le code suivant pour la private function
je ne vois pas trop!!!

Sur une erreur de compilation, regarde ce que la ligne que le compilateur sélectionne.
S'il se rend à la fin du fichier, vérifie qu'a chaque :
- Fuction finisse bien par un End Function-
Sub finisse bien par un End SubChez moi le code de Mercatog compile sans problème.

Sinon, juste pour information, qu'est ce qui ne convient pas dans la solution du post #7 + les fonctions LoadPict et DoesPictExist du post #2 ?

P.S : stp, utilise le bouton <Répondre> plutôt que <Citer> s'il n'y a pas de raison de citer. Car ça alloge sensiblement les réponses.
07/02/2012, 11h58
hottis

Bonjour

les fonctions les fonctions LoadPict et DoesPictExist du post #2 ne sont pas reconnues.

Re bonjour

je crois que je me suis embarqué dans quelque chose d'un peu trop complexe vu mon niveau !!!

Re,

Citation:

Je crois que je me suis embarqué dans quelque chose d'un peu trop complexe

Ok. Faisons simple.

1) Dans le classeur contenant les logos à remplacer insert un bouton dans une des feuilles du classer
2) Copie / colle tout le code ci-dessous dans la feuille VBA correspondant à cette feuille.
Pour éviter les problèmes, garde uniquement ce code dans cette feuille.

3) Ajuste :
- le nom du fichier où se trouve le nouveau logo. (voir NewLogoFile)
- les coordonnées de recherche de l'ancien logo (voir ligne 14)
- le nom du bouton "CommandButton1"

4) Clique sur le bouton.

5) S'il reste des anciens logos sur certaines feuilles, ajoute les coordonnées (ligne pour cherche un peu plus à gauche, et un peu plus bas).

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
50
51
52
53
54
55
Option Explicit
Const NewLogoFile As String = "<le chemin vers le dossier contenant l'image à charger>"
 
Private Sub CommandButton1_Click()
    Dim ws As Worksheet
     For Each ws In Worksheets
        Call LoadPict(ws, GetLogoPictureName(ws), NewLogoFile)
    Next ws
End Sub
 
Private Function GetLogoPictureName(ws As Worksheet) As String
    Dim p As Object
    For Each p In ws.Pictures
        If (p.Left < 10) And (p.Top < 30) Then
            GetLogoPictureName = p.Name
            Exit For
        End If
    Next p
End Function
 
Private Function DoesPictExist(ws As Worksheet, PictName As String) As Boolean
    DoesPictExist = False
 
    Dim p As Object
    For Each p In ws.Pictures
        If p.Name = PictName Then
            DoesPictExist = True
            Exit For
        End If
    Next p
End Function
 
 
Private Sub LoadPict(ws As Worksheet, PictName As String, filename As String)
    Dim l As Integer, t As Integer, w As Integer, h As Integer
 
    If DoesPictExist(ws, PictName) Then
        With ws.Pictures(PictName)
            l = .Left
            t = .Top
            w = .Width
            h = .Height
            .Delete
        End With
 
       With ws.Pictures.Insert(filename)
           .Name = PictName
           .Left = l
           .Top = t
           .Width = w
           .Height = h
       End With
 
    End If
End Sub

07/02/2012, 15h27
hottis

1 pièce(s) jointe(s)

redimensionner image

Rebonjour

je viens de faire la manip

l'ancien logo s'efface bien en revanche ça plante sur

With ws.Pictures.Insert(filename)

Bonsoir,

Il doit y avoir une erreur dans le chemin indiqué pour charger l'image.
Remplace la fonction CommandButton1_Click donné précédemment par celle-ci.
Lorsqu'une fenêtre demandant un nom de fichier s'ouvre, sélectionne le fichier image du nouveau logo.
Code:

1 2 3 4 5 6 7 8 Private Sub CommandButton1_Click() Dim ws As Worksheet Dim logoFile As String logoFile = Application.GetOpenFilename For Each ws In Worksheets Call LoadPict(ws, GetLogoPictureName(ws), logoFile) Next ws End Sub

1 pièce(s) jointe(s)

redimensionner image

Bonsoir cette fois çi ça plante sur autre chose

sur la fnct delete à la fin et pourtant l'image du nouveau logo à bien été inséré mais pas au bon format.

je joins la prog. que j'ai

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
50
51
52
53
54
55
56
57
Option Explicit
Const NewLogoFile As String = "C:Logo.bmp"
 
 Private Sub CommandButton101_Click()
    Dim ws As Worksheet
    Dim logoFile As String
    logoFile = Application.GetOpenFilename
     For Each ws In Worksheets
        Call LoadPict(ws, GetLogoPictureName(ws), logoFile)
    Next ws
End Sub
 
 
Private Function GetLogoPictureName(ws As Worksheet) As String
    Dim p As Object
    For Each p In ws.Pictures
        If (p.Left < 150) And (p.Top < 150) Then
            GetLogoPictureName = p.Name
            Exit For
        End If
    Next p
End Function
 
Private Function DoesPictExist(ws As Worksheet, PictName As String) As Boolean
    DoesPictExist = False
 
    Dim p As Object
    For Each p In ws.Pictures
        If p.Name = PictName Then
            DoesPictExist = True
            Exit For
        End If
    Next p
End Function
 
 
Private Sub LoadPict(ws As Worksheet, PictName As String, filename As String)
    Dim l As Integer, t As Integer, w As Integer, h As Integer
 
    If DoesPictExist(ws, PictName) Then
        With ws.Pictures(PictName)
            l = .Left
            t = .Top
            w = .Width
            h = .Height
            .Delete
        End With
 
       With ws.Pictures.Insert(filename)
           .Name = PictName
           .Left = l
           .Top = t
           .Width = w
           .Height = h
       End With
 
    End If

End Sub

07/02/2012, 20h59
BlueMonkey

Re.

L'erreur dans le code précédent venait bien du nom de fichier.
Pour indiquer un fichier se trouvant à la racine du lecteur C, pensez à mettre le caractère en rouge.

Const NewLogoFile As String = "C:\Logo.bmp"Dans le code actuel, ce problème est résolu avec l'utilisation de la boîte de dialogue.

Citation:

Cette fois çi ça plante sur autre chose
sur la fnct delete à la fin et pourtant l'image du nouveau logo à bien été inséré mais pas au bon format.

Au post précédent la suppression ne plantait pas.
Est-ce que l'image du logo A est toujours présente ?
Est-ce que les feuilles ne sont pas protégées ?

P.S : Merci de sélectionner le code, puis de cliquer sur le bouton http://www.developpez.net/forums/images/editor/code.gif pour que le code se mette en forme dans les messages.
07/02/2012, 22h59
hottis

1 pièce(s) jointe(s)

Bonsoir de nouveau

Est-ce que l'image du logo A est toujours présente ?non elle n'est plus là
Est-ce que les feuilles ne sont pas protégées ?elles le sont à l'origine mais je les ai déprotégés avant la manip

sur la capture jointe , le logo B est inséré à la place du logo A mais apas avec les bonnes dimensions .

j'ai reessayé en ne gardant que quelque onglets

j'ai supprimé les autres

ça fonctionne , les logos A sont supprimés et les logos B insérés, la macro ne plante plus

en revanche le format des images n'est pas bon , comme sur le cr précédent
07/02/2012, 23h18
BlueMonkey
Re,

Les images sont configurer par défaut pour conserver les proportions.
Comme le nouveau logo est sensiblement plus long que l'ancien, il déborde.

Une des façon de limiter le problème de largueur est d'intervertir les lignes en rouges.
Code:

1 2 3 4 5 6 7 With ws.Pictures.Insert(filename) .Name = PictName .Left = l .Top = t .Width = w .Height = h End With
Une autre solution serait de désactiver le ratio proportionnel
LockAspectRatio = msoFalse en passant par le ShapeRange

Bonjour

ça fonctionne , c'est nickel

en fait tous les onglets n'étaient pas visibles:cry:

, il y en avait de cachés et donc de protéger c'est ce qui plantait la macro.

En tous car un GRAND MERCI pour votre aide et votre patience

pour le shape range ça va etre quelque chose de ce style là non ??
Code:

1 2 3 4 5 6 7 8 9 10 t= Selection.ShapeRange.Top l = Selection.ShapeRange.Left h= Selection.ShapeRange.Height w= Selection.ShapeRange.Width .Delete Selection.ShapeRange.Top = t Selection.ShapeRange.Left = l Selection.ShapeRange.Width = h Selection.ShapeRange.Width = w

Voir 40 message(s) de cette discussion en une page