Redimension Picture

[fredannab]

Bonjour
J'ai une macro qui en fonction d'une reference insère un croquis qui s'apelle ref.jpg (ref étant prédéfini comme une variable)
Le truc c'est que toutes les photos n'ont pas la même dimentsion (petites ou larges) et je me demandais s'il y avait moyen d'automatiser le redimensionnement de la photo pour que quelle que soit la taille initiale la photo s'insère puis se redimensionne automatiquement.
Des idées?

 

[PMO2]

Re : Redimension Picture

Bonjour,

Je n'ai pas compris ce que vous voulez faire et je balance entre 2 demandes.

1) Faut-il redimensionner les images qui sont INCLUSES dans Excel

2) ou alors redimensionner les images SOURCE dans leur dossier. Ceci peut être fait mais comporte des restrictions dues a l'orientation verticale ou horizontale de chaque image et à leur ajustement automatique par Windows.

Quelle est la bonne demande ?

Cordialement.

PMO
Patrick Morange

 

[fredannab]

Re : Redimension Picture

Bonjour, merci pour votre réponse, j'étais passé à autre chose en laissant mon fichier en plan en attendant....
C'est le 1), je souhaite que la macro redimensionne les images après les avoir insérer

 

[PMO2]

Re : Redimension Picture

Bonjour,

Une piste avec le code suivant à copier dans un module standard

'### Constantes à adapter ###
Const LARGEUR As Double = 140
Const HAUTEUR As Double = 100
Const CELLULE_BASE = "D1"
'#############################

Sub EgaliseLesPhotos()
Dim S As Worksheet
Dim PICT As Picture
Dim x#
Dim i&
Dim myTOP&
Set S = ActiveSheet
For i& = 1 To 2 'on traite 2 fois pour affinage
  myTOP& = S.Range(CELLULE_BASE).Top
  For Each PICT In S.Pictures
    With PICT
      .Top = myTOP&
      .Left = S.Range(CELLULE_BASE).Left
      .Width = LARGEUR
      .Height = HAUTEUR
      myTOP& = myTOP& + .Height 'nouvelle position verticale
      x# = 1
      If .Width < LARGEUR Then
        Do
          .ShapeRange.ScaleWidth x#, msoFalse, msoScaleFromTopLeft
          x# = x# + 0.01
        Loop Until .Width >= LARGEUR
      ElseIf .Width > LARGEUR Then
        Do
          .ShapeRange.ScaleWidth x#, msoFalse, msoScaleFromTopLeft
          x# = x# - 0.01
        Loop Until .Width <= LARGEUR
      End If
    End With
  Next PICT
Next i&
End Sub

Dans le cas présent, les photos s'alignent sur la colonne D à partir de la ligne 1
Vous pouvez adapter à votre usage les constantes cernées par des ###

Cordialement.

PMO
Patrick Morange