redimensioner une image dans les cellules N3:P6

[laskoo87]

Bonjour,

Alors voila mon problème... J'essaye de redimensionner mon image dans les cellules N36 mais rien a faire, je n'y arrive pas!!

Pourriez vous me dire où est le problème dans mon code svp?
Dernière chose, si vous savez comment faire pour qu'elle ne se déforme pas se serai génial !! J'opte pour le ".LockAspectRatio = msoTrue" mais je ne suis pas sur... Je débute en macro...

Merci d'avance!

Sub InsertionImage()
Dim Emplacement As Range
Dim image As Object
Dim ShapeObj As Object

ActiveSheet.Unprotect ("mdp")

On Error GoTo fin:
For Each ShapeObj In ActiveSheet.DrawingObjects ' boucle pour supprimer ancienne image
If ShapeObj.Name = "cible" Then ActiveSheet.Shapes("cible").Delete
Next ShapeObj

Application.Dialogs(xlDialogInsertPicture).Show
Set Emplacement = Range("N3:P6")

Set image = ActiveSheet.DrawingObjects 'adapter selon nombre total de shapes dans feuille
With image.ShapeRange
.Name = "cible" ' nommer l'image insérée ( pour la supprimer plus facilement ensuite )
.LockAspectRatio = msoFalse
.Left = Emplacement.Left
.Top = Emplacement.Top
.Height = Emplacement.Height
.Width = Emplacement.Width
End With

Exit Sub
fin:
If Err = 1004 Then MsgBox "Insertion d'image interrompue . "

ActiveSheet.Protect ("mdp")

End Sub

 

[Bebere]

Re : redimensioner une image dans les cellules N36

bonjour Laskoo
pour effacer,adapter feuil1
For Each shp In Feuil1.Shapes
If shp.TopLeftCell.Address = Range("N3").Address Then shp.Delete
Next shp


adapter NOmDisque,NomDossier,NomImage

Sub TestInsertPictureInRange()'pour essai
InsertPictureInRange "E:\NomDossier\NomImage.gif", _
Range("N36")
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

à bientôt

 

[laskoo87]

Re : redimensioner une image dans les cellules N36

Bonjour bebere,

Merci pour le code mais ce n'est pas exactement ce dont j'ai besoin...

En gros, je souahiterai faire cela:
1. Selection de l'image à travers la fenetre d'importation image
2. Elle se place en cellule N3
3. Elle se redimensionne pour tenir sur la palge de cellule N36

Dans le code que tu m'as donné, je dois indiquer l'url dans la macro mais elle peut etre changée à tout moment...

Aurai tu une autre idée pour moi?

Merci d'avance.

 

[laskoo87]

Re : redimensioner une image dans les cellules N36

un petit up !

 

[kiki29]

Re : redimensioner une image dans les cellules N36

Salut, tu devrais trouver qqch sur le site de Jacques Les images et shapes

 

[néné06]

Re : redimensioner une image dans les cellules N36

Bonjour Laskoo87, Salutation à kiki29 et Bebere

Perso , j'utilise ce code ,mais qui convient pour des images de dimension sensiblement identique.

Essayes et adaptes

Dim image As Object
Cells(x, y).Select
On Error Resume Next
If Cells(x,y) <> "" Then
ActiveSheet.Pictures.Insert(ActiveWorkbook.Path & "\images\" & Cells(x,y) & ".jpg").Select
Selection.ShapeRange.Width = 110
Set image = Selection.ShapeRange
Selection.ShapeRange.Name = Cells(x,y)
End If

A+

 

[Hippolite]

Re : redimensioner une image dans les cellules N36

Bonjour à tous,
Ton code ajusté :

Sub InsertionImage()
    Dim Emplacement As Range
    Dim image As Object
    Dim ShapeObj As Object

    ActiveSheet.Unprotect ("mdp")

    On Error GoTo fin:
    For Each ShapeObj In ActiveSheet.DrawingObjects    ' boucle pour supprimer ancienne image
        If ShapeObj.Name = "cible" Then ActiveSheet.Shapes("cible").Delete
    Next ShapeObj

    Application.Dialogs(xlDialogInsertPicture).Show
    Set Emplacement = Range("N3:P6")

    Set image = ActiveSheet.DrawingObjects    'adapter selon nombre total de shapes dans feuille
    With image.ShapeRange
        .Name = "cible"    ' nommer l'image insérée ( pour la supprimer plus facilement ensuite )
        .LockAspectRatio = msoTrue
        .Left = Emplacement.Left
        .Top = Emplacement.Top
        .Height = Emplacement.Height
        If .Width > Emplacement.Width Then .Width = Emplacement.Width
    End With

    Exit Sub
fin:
    If Err = 1004 Then MsgBox "Insertion d'image interrompue . "

    ActiveSheet.Protect ("mdp")

End Sub

A+

 

[laskoo87]

Re : redimensioner une image dans les cellules N36

Merci à tous pour votre aide!!
Je suis presque au bout de mon problème mais j'ai encore un tout petit soucis....

Mon image ne s'insert pas dans la bonne cellule si cette dernière n'est pas sélectionée.

Il faut absolument que l'image aille dans ma cellule N3 et non pas en A1 (si A1 est selectionné).

J'ai donc compilé vos différents code afin de donner cela:

Sub InsertionImage()
    Dim Emplacement As Range
    Dim image As Object
    Dim ShapeObj As Object

ActiveSheet.Unprotect ("mdp")

    On Error GoTo fin:
    For Each ShapeObj In ActiveSheet.DrawingObjects    ' boucle pour supprimer ancienne image
       If ShapeObj.Name = "cible" Then ActiveSheet.Shapes("cible").Delete
    Next ShapeObj

   Application.Dialogs(xlDialogInsertPicture).Show
Set Emplacement = Range("N3")
Selection.ShapeRange.Width = 160
Selection.ShapeRange.Height = 110
Set image = Selection.ShapeRange

ActiveSheet.Protect ("mdp")
    
    Exit Sub
fin:
    If Err = 1004 Then MsgBox "Insertion d'image interrompue . "

End Sub

J'ai également trouver cela :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$N$3" Then InsertionImage
End Sub

Mais je n'arrive pas à intégrer cette dernière macro dans la mienne...
Avez vous une idée?

C'est ma dernière demande et je ne vous ennui plus... jusqu'à mon prochain problème

Merci encore!

Laskoo

 

[néné06]

Re : redimensioner une image dans les cellules N36

Si la cellule change le code sélection s exécute automatique et il est place dans les feuilles
Il y a moyen de désactiver cette routine
A+

Post envoyé depuis un tel portable

 

[laskoo87]

Re : redimensioner une image dans les cellules N36

Merci de ta réponse néné06 mais je ne comprends pas du tout ce que tu a écris... lol

 

[néné06]

Re : redimensioner une image dans les cellules N36

Cette macro ne s,appel pas mais elle s' exécute automatiquement a chaque changement ou déplacement de cellule dans ta feuille
A+

 

[laskoo87]

Re : redimensioner une image dans les cellules N36

Ok, je comprends mieux!
Est ce qu'il est possible d'annuler "cette routine" comme tu dis dans ton précédent message et de bloquer cette macro sur une seule cellule?

Si oui je continu a chercher, sinon, problème résolu !

 

[néné06]

Re : redimensioner une image dans les cellules N36

Actuellement a chaque changement de position de cellule la routine s'exécute,mais elle ne fait rien sauf si la cellule est la
Est la N3

Comme j,indique plus haut,je suis sur téléphone et j,ai du mal
A+

 

[laskoo87]

Re : redimensioner une image dans les cellules N36

Pas de problème, merci pour ton aide!
Je vais essayer de trouver une solution alternative car je ne sais pas du tout par où prendre la solution que tu m'indique.
Désolé, je ne suis aps très bon dans ce language...
++

 

[Bebere]

Re : redimensioner une image dans les cellules N36

bonjour Laskoo,Néné,Hippolite,Kiki
si ton code est insertionimage
change
Set Emplacement = Range("N3")
par
Range("N3").select

où supprime
Set Emplacement = Range("N3")
et remplace
selection
par Range("N3")
selection dans ton code est nothing
à bientôt