Photo dans cellule fusionner - ratio et centrer

Bonjour à tous,

Je fais appel à vos connaissances, après beaucoup d'essais erreur, j'ai réussis à insérer une photo dans ma feuille à partir du code...

Le problème la photo s'affiche n'importe ou dans la feuille.

J'aimerais que la photo s'affiche dans l'espace délimité C44:J54, en respectant le ratio de la photo et centré dans cet espace.

voici le code que j'ai jusqu’à présent

    Dim design As String
    Dim c As Range
    Dim ws As Worksheet
    Set ws = Sheets("F_C_Port_8x11")

    design = "\\chemin_de_l'image\Dossier photo\" & uf_Inventaire.tb_NoDossier & "\Photo\PhotoR.jpg"
    ws.Select
    With ActiveSheet

     On Error Resume Next
       .Shapes("FICHE").Delete

     Set c = .Range("C44").MergeArea
       .Pictures.Insert(design).Name = "FICHE"
       .Shapes(Name).Left = c.Left 
       .Shapes(Name).Top = c.Top 
       .Shapes(Name).LockAspectRatio = msoFalse
       .Shapes(Name).Height = c.Height
       .Shapes(Name).Width = c.Width

    End With

Merci de bien vouloir jeter un oeil à mon problème.

Bonjour Mtek,

Il ne manquait que ... sélectionner la cellule "mergée" avant l'opération ...

Sub testetejiji()

    Dim design As String
    Dim c As Range
    Dim ws As Worksheet

    Set ws = Sheets("F_C_Port_8x11")
    design = "\\chemin_de_l'image\Dossier photo\" & uf_Inventaire.tb_NoDossier & "\Photo\PhotoR.jpg"

    ws.Select

    With ActiveSheet

        On Error Resume Next
        .Shapes("FICHE").Delete
        .Range("C44").Select        ' <<< ajout ric

        Set c = .Range("C44").MergeArea
        .Pictures.Insert(design).Name = "FICHE"
        .Shapes(Name).Left = c.Left
        .Shapes(Name).Top = c.Top
        .Shapes(Name).LockAspectRatio = msoFalse
        .Shapes(Name).Height = c.Height
        .Shapes(Name).Width = c.Width
    End With
End Sub

ric

Bonjour Ric,

Merci de prendre du temps pour m'aider,

Effectivement avec ton ajout, la photo se positionne au bon endroit, mais, en trop grand.

La photo doit être à l'intérieur des cellule fusionner, et si possible, centrer

Bonjour,

Je ne suis pas un habitué des images ...

Je regarde et reviens ...

ric

Merci Ric pour ton temps, c'est très apprécié,

Voici un bout de code trouvé sur le web, mais que je n'arrive pas à adapter... peut être ça pourra aider....

' http://boisgontierj.free.fr/
Sub CentrageChamp()
  Set champ = Range("B2:F12")
  Set img = ActiveSheet.Shapes(1)
  img.Top = champ.Top + champ.Height / 2 - img.Height / 2
  img.Left = champ.Left + champ.Width / 2 - img.Width / 2
End Sub

Bonjour,

Si Sheets("F_C_Port_8x11") est la même feuille que ActiveSheet ... il y a du code de trop ...

Ça fonctionne si l'on sélectionne l'image pour déverrouiller le ratio ...

'' voir code plus bas ...

ric

La feuille est appeler d'un userform, il y a beaucoup de feuille, et beaucoup d'userform, donc pour éviter les bogues, je préfère appeler la bonne feuille Sheets("F_C_Port_8x11") , mais je peux être dans l'erreur (je suis encore novice).

Je suis ouvert au suggestion :)

Bonjour Mtek,

Pour les feuilles ... utilise ".Activate" ... au lieu de ".Select" ...

Puis, le set n'est utilisé que pour sélectionner la feuille ... il est donc inutile ...

'' ceci 
   Set ws = Sheets("F_C_Port_8x11")
    ws.Select

'' peut être remplacé par 
 Sheets("F_C_Port_8x11").Activate

ric

J'ai un message d'erreur

rapexcel 2 rapexcel

Bonjour Mtek,

Désolé ... j'ai trop nettoyé avant de coller sur le forum ..

Ceci est testé et fonctionnel ...

    Dim design As String
    Dim c As Range
    Dim ws As Worksheet

    Sheets("F_C_Port_8x11").Activate
    design = "\\chemin_de_l'image\Dossier photo\" & uf_Inventaire.tb_NoDossier & "\Photo\PhotoR.jpg"

    With ActiveSheet

        On Error Resume Next
        .Shapes("FICHE").Delete

        .Range("C44").Select 

        Set c = .Range("C44").MergeArea
        .Pictures.Insert(design).Name = "FICHE"
        With .Pictures
            .Left = c.Left
            .Top = c.Top

            ActiveSheet.Shapes.Range(Array("FICHE")).Select
            Selection.ShapeRange.LockAspectRatio = msoFalse

            .Height = c.Height
            .Width = c.Width
        End With
    End With

ric

Bonjour Ric,

La solution est de plus en plus proche,
La photo entre parfaitement dans les cellules fusionné, mais sans respecter le ratio ( la photo est déformer )...

(je quitte le bureau, de retour demain)

merci pour tout le temps que tu y mets

Bonjour Mtek,

Pour garder le ratio verrouillé : msoTrue ...

ric

Bonjour Mtek, Ric,

Cela se déroule en deux temps.

En premier on recueille les dimensions du groupe de cellules fusionnées. Et en deuxième on applique celles-ci à l'image.

Sub Photo()
Set Ash = ActiveSheet
'Conservation des dimensions des cellules fusionnées puis Insertion si image inexistante
Sheets("F_C_Port_8x11").Activate
design = "\\ad.animex.com....etc...jpg"
Set Ash = ActiveSheet
With Ash.[C44]
H = .MergeArea.Height
W = .MergeArea.Width
L = .MergeArea.Left
T = .MergeArea.Top
On Error Resume Next
Ash.Shapes("Fiche").Delete
Ash.Pictures.Insert(design).Name = "Fiche"
End With
'Positionnement et taillage de l'image
With Ash.Shapes("Fiche")
.Left = L
.Top = T
.LockAspectRatio = msoFalse
.Height = H
.Width = W
 End With
End Sub

Eventuellement on peut amoindrir légèrement la hauteur H de l'image et sa largeur W pour des effets de bord.

Bonjour C Cellus, merci à toi aussi de bien vouloir te pencher sur mon problème.

Ton code fonctionne bien, la photo est bien centré, et au bon ratio, mais trop grande pour les cellule fusionné.... voir photo ci joint.

rapexcel 3

Bonjour Ric

Ton code fonctionne bien, la photo est bien centré, et au bon ratio, mais trop grande pour les cellule fusionné....

A nouveau,

La photo provient directement d'un site, c'est cela.

Elle n'est pas sauvée dans un dossier du PC (exemple: Dossier Images).

Puis ensuite reprise par la méthode Insert.

Dans Propriétés de l'image, au niveau Taille.

image

Comment est-elle paramétrée?

Bonjour X Cellus

Les photos sont dans le serveur de la compagnie (localement).

J'ai trouvé une solution

J'ai ajouté ce code à la suite de ton code...

et tout fonctionne comme souhaité

Set Emplacement1 = Range("c44:j54")
    With ActiveSheet.Shapes("FICHE")
    If .Width > Emplacement1.Width Then ratL = .Width / Emplacement1.Width
    If .Height > Emplacement1.Height Then ratH = .Height / Emplacement1.Height
    rat = Application.Max(ratL, ratH)
    If rat <> 0 Then .Width = .Width / rat
    .Left = Emplacement1.Left + Emplacement1.Width / 2 - .Width / 2
    .Top = Emplacement1.Top + Emplacement1.Height / 2 - .Height / 2
    End With

Suite,

Je viens de tester le code proposé sur une image directement téléchargé d'un site photo.

Et elle s'est correctement insérée dans les cellules fusionnées. Voir avec le lien ci-dessous

image

Suite,

Donc, tes cellules (C44 à J54) n'étaient pas des cellules fusionnées.

Ce qui est étonnant c'est la ligne 53 qui est bien plus haute que les autres.

On me demander d'automatiser un formulaire créer par une employée,

Le résultat souhaité est obtenu merci à Ric et X Cellus pour votre temps, votre aide est très très apprécié.

Rechercher des sujets similaires à "photo fusionner ratio centrer"