redimensionner image lors d'une insertion automatique dans une cellule fusionnée

[jeromeN95]

Bonjour a tous,
j'ai un bout de code qui insert une image selon condition...
Mais l'image issu d'une recherche stocké sur le pc à une taille variable.

Je souhaite la redimentionnée automatiquement SVP :
Ce bout de code ne me convient pas vraiment...

.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

Merci

 

[job75]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Bonjour jeromeN95,

A adapter :

Sub Image()
Dim c As Range, a As Range
Set c = ActiveCell
Set a = c.MergeArea
With ActiveSheet.Shapes("Picture 1") 'à adapter
  .LockAspectRatio = True 'pour conserver les proportions de l'image
  .Top = c.Top
  .Left = c.Left
  If .Height / .Width > a.Height / a.Width Then
    .Height = a.Height
  Else
    .Width = a.Width
  End If
End With
End Sub

A+

 

[jeromeN95]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Impecable, ça fonctionne mais reste a adapté l'image inserer :

'Insérer Image Doseur
If Me.LstDoseur <> "" Then
    InsertImage "\\sparte.asp.fr\data\adv\photos\" & Me.LstDoseur & ".jpg"
Dim a As Range
Set c = ActiveCell
Set a = c.MergeArea
With ActiveSheet.Shapes("Image 163") 'à adapter pour l'image vennat d'être inserer
  .LockAspectRatio = True 'pour conserver les proportions de l'image
  .Top = c.Top
  .Left = c.Left
  If .Height / .Width > a.Height / a.Width Then
    .Height = a.Height
  Else
    .Width = a.Width
  End If
End With
End If

 

[jeromeN95]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

J'ai essayer comme ceci mais pas de redimentionnement :

'Insérer Image Doseur
If Me.LstDoseur <> "" Then
    InsertImage "\\sparte.asp.fr\data\adv\photos\" & Me.LstDoseur & ".jpg"
    
    'ici
Dim a As Range
Set c = ActiveCell
Set a = c.MergeArea
Set im = "\\sparte.asp.fr\data\adv\photos\" & Me.LstDoseur & ".jpg"
With ActiveSheet.Shapes = im 'à adapter
  .LockAspectRatio = True 'pour conserver les proportions de l'image
  .Top = c.Top
  .Left = c.Left
  If .Height / .Width > a.Height / a.Width Then
    .Height = a.Height
  Else
    .Width = a.Width
  End If
End With
   'ici
End If

 

[hamcec]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Bonjour,

Le bout de code ci-dessous permet de redimensionner l'image insérée dans une plage à cellules fusionnées !

Sub InsertPicture()
Dim MaSelection As Range
Dim MyPicture As Picture
Dim image$
image = "c:\mon_image.jpg"
Set MaSelection = Selection
MaSelection.Select
Set MyPicture = ActiveSheet.Pictures.Insert(image)
With MyPicture.ShapeRange
.LockAspectRatio = msoFalse
.Height = MaSelection.Height
.Width = MaSelection.Width
End With
MaSelection.Select
End Sub

Cdt, Hamcec.

 

[job75]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Re,

Allons allons, vous croyez que ceci à un sens :

With ActiveSheet.Shapes = im 'à adapter

Utilisez 8% d'Excel...

A noter que là on est simplement dans la création d'image, ce n'est plus le sujet du fil.

A+

 

[jeromeN95]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Bonjour,
j'ai essayer ceci :

'Insérer Image Doseur
If Me.LstDoseur <> "" Then
    InsertImage "\\sparte.asp.fr\data\adv\photos\" & Me.LstDoseur & ".jpg"

Dim MaSelection As Range
Dim MyPicture As Picture
Dim image
image = "c:\mon_image.jpg"
Set MaSelection = Selection
MaSelection.Select
Set MyPicture = ActiveSheet.Pictures.Insert(image)
With MyPicture.ShapeRange
.LockAspectRatio = msoFalse
.Height = MaSelection.Height
.Width = MaSelection.Width
End With
MaSelection.Select

 

[hamcec]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Si tu veux adapter mon bout de code au tien, il suffit de remplacer "c:\mon_image.jpg" par ton nom de fichier "\\sparte.asp.fr\data\adv\photos\" & Me.LstDoseur & ".jpg", ce qui donne :

Sub InsertPicture()
Dim MaSelection As Range
Dim MyPicture As Picture
Dim image$
If Me.LstDoseur <> "" Then
image = "\\sparte.asp.fr\data\adv\photos\" & Me.LstDoseur & ".jpg"
Set MaSelection = Selection
MaSelection.Select
Set MyPicture = ActiveSheet.Pictures.Insert(image)
With MyPicture.ShapeRange
.LockAspectRatio = msoFalse
.Height = MaSelection.Height
.Width = MaSelection.Width
End With
MaSelection.Select
End If
End Sub

A+, Hamcec.

 

[job75]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Re,

Pas mal du tout, vous avez bien trouvé ShapeRange.

Alors essayez ce code :

'Insérer Image Doseur
If Me.LstDoseur <> "" Then
  Dim im As Object, c As Range, a As Range
  Set im = ActiveSheet.Pictures.Insert("\\sparte.asp.fr\data\adv\photos\" & _
    Me.LstDoseur & ".jpg")
  Set c = ActiveCell
  Set a = c.MergeArea
  With im.ShapeRange
    .LockAspectRatio = True 'pour conserver les proportions de l'image
    .Top = c.Top
    .Left = c.Left
    If .Height / .Width > a.Height / a.Width Then
      .Height = a.Height
    Else
      .Width = a.Width
    End If
  End With
End If

A+

 

[hamcec]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Merci pour le ShapeRange.

Une petite remarque : en fonction de la plage fusionnée cible, les proportions de l'image ne pourront pas être conservées ...

Cdt, Hamcec.

 

[job75]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Bonsoir hamcec,

Une petite remarque : en fonction de la plage fusionnée cible les proportions de l'image ne pourront pas être conservées ...

Apparemment, vous n'avez pas testé ma macro. Pas bien ça !

A+

 

[hamcec]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Bonsoir job75,

Votre code avait bien entendu été testé.

En me référant au titre du post "redimensionner image lors d'une insertion automatique dans une cellule fusionnée", je voulais simplement indiquer que l'image redimensionnée ne peut recouvrir l'ensemble de la plage fusionnée en conservant ses proportions initiales.

A+.

 

[job75]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

Re,

Très juste hamcec.

Avec 8% d'Excel seulement, on comprend qu'un oeuf agrandi ne recouvrira jamais un boeuf.

A+

 

[jeromeN95]

Re : redimensionner image lors d'une insertion automatique dans une cellule fusionnée

7% c'est mon abjectif !

Serieusement, ca marche super bien.
Merci