Encore inserer des images

JBOBO · 3 Novembre 2010

Bonjour,

Toujours pour un meme fichier mais demande totalement differente !

Je souhaiterais inserer des images dans des cellules fusionnées et que celles ci soit dimensionnées automatiquement en fonction soit de la hauteur, soit de la largeur de la cellule (la premiere limite atteinte en fait) et qu'elle ne soit si possible pas déformé.
Je suis completement perdu car je ne sais pas si c'est possible ! j'ai vu que notre ami J.BOISGONTIER faisait des prouesses inimaginables dans ce domaine, mais je ne comprends pas grand chose aux codes qui correspondent et je serais bien capable de les adapter.

j'ai creer une formule pour récupérer le chemin et le nom de la photo en fonction du numéro, mais pour l'instant ça ne sert pas à grand chose car je n'arrive pas à utiliser cette formule pour l'associer à une insertion d'image.

Bref je ne sais pas par où commencer, je joint un fichier que j'espère assez clair et si ce n'est pas le cas faites moi signe.

merci

BOISGONTIER · 3 Novembre 2010

Re : Encore inserer des images

Bonjour,

voir pj

Les images et shapes

=AfficheImage(J13&".jpg";"c:\mesdoc\")

Code:

Function AfficheImage(NomImage, rep)
  Application.Volatile
  Set adr = Application.Caller
  Set adr2 = Range(adr.Address).MergeArea
  temp = NomImage & "_" & adr.Address
  Existe = False
  For Each s In adr.Worksheet.Shapes
    If s.Name = temp Then Existe = True
  Next s
  If Not Existe Then
     For Each k In adr.Worksheet.Shapes
        p = InStr(k.Name, "_")
        If Mid(k.Name, p + 1) = adr.Address Then k.Delete
     Next k
     If Dir(rep & NomImage) = "" Then
        AfficheImage = "Inconnu"
     Else
       Set myShell = CreateObject("Shell.Application")
       Set myFolder = myShell.Namespace(rep)
       Set myFile = myFolder.Items.Item(NomImage)
       Taille = myFolder.GetDetailsOf(myFile, 26)
       H = Val(Split(Taille, "x")(1))
       L = Val(Split(Taille, "x")(0))
       Ech = adr2.Height / H
       H = H * Ech
       L = L * Ech
       Set s = adr.Worksheet.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, L, H)
       s.Name = NomImage & "_" & adr.Address
       AfficheImage = ""
    End If
  End If
End Function

JB

JBOBO · 3 Novembre 2010

Re : Encore inserer des images

Merci beaucoup pour cette réponse rapide,

2 petites questions si je peux abuser encore un peu

1 - Actuellment la macro dimensionne l'image par rapport à la hauteur de la cellule fusionnée. Est t'il possible que si la largeur de l'image dépasse de la cellule, alors que l'image soit dimensionnée par rapport à cette largeur et non plus sur la hauteur

2 - Quand je rentre le chemin manuellement dans la formule, il m'insère bien l'image, par contre quand le chemin est dans une cellule,il me met "#valeur!"

par exemple AfficheImage(J16&".jpg";Q10) avec c:\mesdocs\ en Q10 ne marche pas alors que AfficheImage(J16&".jpg";"c:\mesdocs\") marche correctement.

en tout cas merci encore pour cette fonction

BOISGONTIER · 3 Novembre 2010

Re : Encore inserer des images

http://boisgontierjacques.free.fr/fichiers/Images/FonctionAfficheImage5.xls

Code:

Function AfficheImage(NomImage, rep)
  Application.Volatile
  Set adr = Application.Caller
  Set adr2 = Range(adr.Address).MergeArea
  temp = NomImage & "_" & adr.Address
  Existe = False
  For Each s In adr.Worksheet.Shapes
    If s.Name = temp Then Existe = True
  Next s
  If Not Existe Then
     For Each k In adr.Worksheet.Shapes
        p = InStr(k.Name, "_")
        If Mid(k.Name, p + 1) = adr.Address Then k.Delete
     Next k
     If Dir(rep & NomImage) = "" Then
        AfficheImage = "Inconnu"
     Else
       Set myShell = CreateObject("Shell.Application")
       Set myFolder = myShell.Namespace(rep)
       Set myFile = myFolder.Items.Item(NomImage)
       Taille = myFolder.GetDetailsOf(myFile, 26)
       H = Val(Split(Taille, "x")(1))
       L = Val(Split(Taille, "x")(0))
       echH = adr2.Height / H
       EchL = adr2.Width / L
       If L * echH > adr2.Width Then ech = EchL Else ech = echH
       H = H * ech
       L = L * ech
       Set s = adr.Worksheet.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, L, H)
       s.Name = NomImage & "_" & adr.Address
       AfficheImage = ""
    End If
  End If
End Function

JB

JBOBO · 3 Novembre 2010

Re : Encore inserer des images

re,

Merci beaucoup, vraiment trop rapide !
le dimensionnement marche nickel

seul hic, je n'arrive pas à comprendre pourquoi si j'ai le chemin en A1 et le nom de l'image en A2, pourquoi quand je fais = AfficheImage(A2;A1) ça ne marche pas j'ai un retour #valeur ! et je ne comprends pas pourquoi si ce n'est peut-etre que si les 2 infos sont rentrées manuellement elles sont entre guillemets. Mais du coup je ne sais pas comment contourner le probleme car meme en rajoutant les "" dans les références bah ça marche pas

MAis vous avez déjà fais beaucoup et je ne voudrais pas trop abuser de votre temps.

Encore merci

JBOBO · 3 Novembre 2010

Re : Encore inserer des images

re,

Je crois que j'ai trouvé (j'avoue presque par hasard) . j'ai juste modifié 2 lignes :

Code:

Set myFolder = myShell.Namespace(rep[B].Value[/B])
       Set myFile = myFolder.Items.Item(NomImage[B].Value[/B])

et ça à l'air de fonctionner.

Merci pour tout.

BOISGONTIER · 4 Novembre 2010

Re : Encore inserer des images

Bonjour,

http://boisgontierjacques.free.fr/fichiers/Images/FonctionAfficheImage5.xls

Code:

Function AfficheImage(NomImage, Optional rep)
  Application.Volatile
  If IsMissing(rep) Then rep = ThisWorkbook.Path & "\"
  Set adr = Application.Caller
  Set adr2 = Range(adr.Address).MergeArea
  temp = NomImage & "_" & adr.Address
  Existe = False
  For Each s In adr.Worksheet.Shapes
    If s.Name = temp Then Existe = True
  Next s
  If Not Existe Then
     For Each k In adr.Worksheet.Shapes
        p = InStr(k.Name, "_")
        If Mid(k.Name, p + 1) = adr.Address Then k.Delete
     Next k
     If Dir(rep & NomImage) = "" Then
        AfficheImage = "Inconnu"
     Else
       Set myShell = CreateObject("Shell.Application")
       If TypeName(rep) = "Range" Then
          Set myFolder = myShell.Namespace(rep.Value)
       Else
          Set myFolder = myShell.Namespace(rep)
       End If
       Set myFile = myFolder.Items.Item(NomImage)
       Taille = myFolder.GetDetailsOf(myFile, 26)
       H = Val(Split(Taille, "x")(1))
       L = Val(Split(Taille, "x")(0))
       echH = adr2.Height / H
       EchL = adr2.Width / L
       If L * echH > adr2.Width Then ech = EchL Else ech = echH
       H = H * ech
       L = L * ech
       Set s = adr.Worksheet.Shapes.AddPicture(rep & NomImage, True, True, adr.Left, adr.Top, L, H)
       s.Name = NomImage & "_" & adr.Address
       AfficheImage = ""
    End If
  End If
End Function

JB

JBOBO · 4 Novembre 2010

Re : Encore inserer des images

RE,

Merci à ous ça marche vraiment parfaitement.

Autre petite question : j'ai trouvé ce code qui vous appartient et il me convient presque mais je souhaiterais ne récupérer que la couleur et éventuellement le motif de la cellule sans le contenu car les cellules de destinations contiennent déjà une valeur. Et là je dois vous avouer que je ne comprends rien à rien à ces codes ci dessous et donc je ne vois pas quoi modifier. Si vous pouviez quelques peu éclairer mes lanternes et normalement après ça je pense que je devrais cesser au moins pour un temps d'abuser du votre (de temps).

Merci

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([B3:B53], Target) Is Nothing And Target.Count = 1 Then
     p = Application.Match(Target, Application.Index([Data], , 1), 0)
     If Not IsError(p) Then Sheets("BD").Range("data").Cells(p, 2).Copy Target.Offset(, 1)
  End If
End Sub

Code:

Private Sub Worksheet_Activate() ' pour maj si changement dans la BD
  Application.ScreenUpdating = False
  For Each c In [B3:B53]
     p = Application.Match(c, Application.Index([Data], , 1), 0)
     If Not IsError(p) Then Sheets("BD").Range("data").Cells(p, 2).Copy c.Offset(, 1)
   Next c
   Application.ScreenUpdating = True
End Sub

JBOBO · 4 Novembre 2010

Re : Encore inserer des images

Bonjour,

Je rejoins un petit fichier avec quelques explications supplementaires.

Si quelqu'un passe par là je suis preneur d'info.

BOISGONTIER · 4 Novembre 2010

Re : Encore inserer des images

Bonsoir,

Il y a un problème de coexistence entre la fonction et le coloriage. Autre approche en PJ

JB

JBOBO · 4 Novembre 2010

Re : Encore inserer des images

Bonsoir,

Une fois de plus je vous remercie pour votre aide précieuse.

Je teste cela demain car pas excel sous la main ce soir mais dans tous les cas bravo pour ce que vous faites.

Merci encore

J.Ch

Encore inserer des images

JBOBO

XLDnaute Accro

Pièces jointes

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

JBOBO

XLDnaute Accro

BOISGONTIER

XLDnaute Barbatruc

JBOBO

XLDnaute Accro

JBOBO

XLDnaute Accro

BOISGONTIER

XLDnaute Barbatruc

JBOBO

XLDnaute Accro

JBOBO

XLDnaute Accro

Pièces jointes

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

JBOBO

XLDnaute Accro

Discussions similaires

Encore inserer des images

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

Discussions similaires

Privacy & Transparency

Privacy & Transparency