Insertion d'une image (logo) sur l'entête d'une feuille

Bonjour,

Je cherche à pouvoir :

Récupérer une image sur une feuille, et que cette image soit insérer dans l'entête d'une autre feuille. Il faudrait que cette image se positionne sur l'entête gauche avec une taille sous forme de petit logo.

Je ne suis arriver qu'à copier l'image pour la positionner sur l'autre feuille mais pas sur l'entête (voir fichier ci joint)

Merci pour votre aide.

Bonjour

en suivant ce lien tu trouveras ta réponse

insérer une image dans l'entête de Excel 👌 - YouTube

A+ François

Bonjour,

Merci pour ce retour,

Néanmoins, la vidéo présente sur You Tube ne fait état que d'une insertion manuelle des entêtes. Je cherche un code en VBA qui permettrait d'automatiser cette fonction. (voir mon fichier en pièce jointe lors de la demande initiale)

Claude

Bonjour, j'ai bien peur que ce soit peine perdue ; l'entête d'une feuille excel ne prend pas le copié collé d'une image.

Seule l'insertion du image qui se trouve à l'extérieur au fichier excel.

La seule solution c'est que vos images soit à l'extérieur dans un répertoire commun et que le nom de l'image soit une variable de votre onglet Logo.

Exemple avec le chemin à adapter à vos logos et la variable "nom d'image" en C4 de l'onglet Logo

(dimensions Height et Width à adapater elles aussi.

Sub Macro1()

Sheets("Présentation").Select
ActiveSheet.PageSetup.LeftHeaderPicture.Filename = _
"C:\Users\utilisateur\Desktop\meslogos\" & Worksheets("Logo").Range("C4").Value & ".jpg"
With ActiveSheet.PageSetup.LeftHeaderPicture
.Height = 57
.Width = 54.75
End With

End Sub

Bonjour,

Merci pour cette information.

Une réflexion et peut être une piste

Serait-il possible d'enregistrer l'image sélectionnée par (ActiveSheet.Pictures.Select) ou un code VBA similaire puis :

. D'enregistrer cette image sur C: (fichiers temporaire) et donc ensuite récupérer cette image qui serait en conséquence à l'extérieur du fichier Excel.

La référence au fichier temporaire sur C permettrait de pouvoir utiliser ce programme sur n'importe quel PC sans avoir a faire référence à un nom d'utilisateur.

Néanmoins, Mes connaissance en VBA ne sont pas suffisante pour tenter cette approche.

Claude

Bonjour à tous,

Oui, il est possible de créer une image temporaire. Voici un essai :

Sub Test()
InsertSign Worksheet:=worksheets("Présentation"), Shape:=sheets("Logo").shapes("monlogo"), Height:=57, Width:=54.75
end sub

Sub InsertSign(Worksheet as Worksheet, Shape as Shape, Height as single, Width as single)
dim Filename$, msg$
if Height <= 0 or Width <= 0 or Height >= 1000 or Width >= 1000 then msg = "Les dimensions renseignées sont incorrectes.": goto fin
Filename = environ("userprofile") & "\Desktop\a1z2e3r4t5y6.jpg"
if ExportShapeToJPG(Shape, Filename) then
    with Worksheet.PageSetup.LeftHeaderPicture
        .Filename = Filename
        .Height = Height
        .Width = Width
    End With
else
    msg = "Une erreur est survenue lors de l'insertion de la signature."
end if
if dir(Filename) <> "" then kill Filename
fin:
if msg <> "" then msgbox msg, vbinformation
End Sub

Public Function ExportShapeToJPG(Forme As Shape, Filename as string) As Boolean
'adapté de : https://excel-malin.com/vba-astuces/excel-vers-jpg/
ActiveWindow.DisplayGridlines = False 'cacher ou afficher les lignes de grille
On Error GoTo fin
With Forme
    .CopyPicture Appearance:=xlScreen, Format:=xlPicture 'Copier dans le Presse-papier
    With .Parent.ChartObjects.Add(.Left, .Top, .Width, .Height).Chart 'création nouveau graph temporaire (pour méthode Export)
        .Paste
        .ChartArea.Format.Line.Visible = msoFalse
        .Export Filename
    End With
    ExportShapeToJPG = True
fin:
    If .Parent.ChartObjects.Count > 0 Then .Parent.ChartObjects(.Parent.ChartObjects.Count).Delete
End With
ActiveWindow.DisplayGridlines = True
End Function

avec la feuille à configurer, la forme à exporter puis insérer à bien définir et les hauteur et largeur à adapter.

Cdlt,

Re bonjour,

je viens de tester le code transmis mais il y à un bug :

Le message d'erreur suivant apparait "L'élément portant ce nom est introuvable"

Ligne concernée après débogage :
InsertSign Worksheet:=Worksheets("Présentation"), Shape:=Sheets("Logo").Shapes("monlogo"), Height:=57, Width:=54.75

Ci joint le fichier avec la macro affectée.

Cordialement

Claude

Bonjour,

Ce sont les éléments à adapter justement :

- la feuille à mettre en page : Worksheets("Présentation"),

- la forme à exporter puis insérer dans l'en-tête : Shape:=Sheets("Logo").Shapes("monlogo"),

- la hauteur de l'image : Height:=57,

- la largeur de l'image : Width:=54.75

Je pense en l'occurrence qu'il s'agit de la forme. Il faut bien la cibler. Rendez-vous dessus et faites un clic droit, vous verrez son nom apparaitre dans la barre des références (en haut à gauche, c'est la petite barre à côté de la barre de formules). Le cas échéant, renommez-la pour avoir un nom court et clair. Puis, reprenez son nom dans le code :

sheets("nomdelafeuillecontenantlaforme").shapes("nomdelaforme")

Cdlt,

Bonjour,

Merci pour le temps passé à vos réponses.

J'ai compris pour l'identification des éléments notamment pour le nom de l'image (logo).

Le correctif à été apporté. Le bug à disparu.

Mais il ne se passe rien lorsque l'on appui sur le bouton.

Le logo ne s'insère pas dans l'entête de la feuille présentation (copie du fichier modifié ci joint)

Claude

Re,

Désolé, je n'ouvre pas les fichiers en ce moment. Mais vous pouvez poster le code correspondant en revanche, à l'aide des balises </> du ruban d'icônes.

Vous êtes certain que l'image n'est pas insérée ? Puisqu'évidemment, pour le constater, il faut demander un aperçu de la feuille Présentation, voire imprimer la feuille directement.

Au cas où, vous pouvez exécuter le code au pas à pas détaillé à l'aide de la touche F8. Ca permet de suivre les différentes étapes et éventuellement s'apercevoir d'une anomalie à l'exécution (condition insatisfaite par exemple).

Cdlt,

Bonjour,

Mes deux feuilles sont très simples

La feuille "Logo" comprend une image et un bouton auquel est affecté le code VBA

La deuxième feuille "Présentation" est une feuille vide

En effectuant une commande d'exécution pas à pas détaillé, les seuls modifications qui apparaissent sont les suivantes :

ActiveWindow.DisplayGridlines = False 'cacher ou afficher les lignes de grille

Disparition du quadrillage de la feuille "Logo"

    With .Parent.ChartObjects.Add(.Left, .Top, .Width, .Height).Chart 'création nouveau graph temporaire (pour méthode Export)

Disparition de l'image présente sur la Feuille "Logo"

        .ChartArea.Format.Line.Visible = msoFalse

Disparition de l'encadré de l'image présente sur la Feuille "Logo"

    If .Parent.ChartObjects.Count > 0 Then .Parent.ChartObjects(.Parent.ChartObjects.Count).Delete

Réapparition de l'image sur la Feuille "Logo"

ActiveWindow.DisplayGridlines = True

Réapparition du quadrillage sur la Feuille "Logo"

La Feuille "Présentation restant quand à elle vide.

Claude

En effet, l'image n'apparait pas directement. En me basant sur ce lien https://docs.microsoft.com/fr-fr/office/vba/api/excel.pagesetup.leftheaderpicture et après quelques essais, la modification suivante semble fonctionner :

Sub InsertSign(Worksheet As Worksheet, Shape As Shape, Height As Single, Width As Single)
Dim Filename$, msg$
If Height <= 0 Or Width <= 0 Or Height >= 1000 Or Width >= 1000 Then msg = "Les dimensions renseignées sont incorrectes.": GoTo fin
Filename = Environ("userprofile") & "\Desktop\a1z2e3r4t5y6.jpg"
If ExportShapeToJPG(Shape, Filename) Then
    With Worksheet.PageSetup
        With .LeftHeaderPicture
            .Filename = Filename
            .Height = Height
            .Width = Width
        End With
        .LeftHeader = "&G"
    End With
Else
    msg = "Une erreur est survenue lors de l'insertion de la signature."
End If
If Dir(Filename) <> "" Then Kill Filename
fin:
If msg <> "" Then MsgBox msg, vbInformation
End Sub

Cdlt,

Bonjour,

Excellent travail de votre part.

Le code que vous m'avez transmis fonctionne mais partiellement à savoir :

En mode pas à pas avec la touche F8, tout fonctionne, mais dès lors que l'on lance le fonctionnement normal (soit à travers la macro affectée à mon bouton de commande ou à travers la commande "flèche verte" (exécuter Sub), il ne se passe rien.

J'ai réussi après plusieurs essais à compléter votre code pour un fonctionnement complet en mode pas à pas mais le dysfonctionnement persiste en mode normal.

La ligne qui pose problème est la suivante :

 .Paste

.ChartArea.Format.Line.Visible = msoFalse

.Export Filename

End With

ExportShapeToJPG = True

A partir de .paste en appuyant sur la flèche verte (exécuter Sub), tout fonctionne. Idem en mode pas à pas.

Par contre si je tente de lancer un fonctionnent normal (ecécuter sub) à partir de la ligne précédente, il ne se passe rien alors que cela fonctionne toujours en mode pas à pas????

J'ai essayé de ralentir le programme en intercalant entre ces deux lignes une fonction d'attente de 1 secondes mais sans modification du résultat.

With Forme

.CopyPicture Appearance:=xlScreen, Format:=xlPicture 'Copier dans le Presse-papier

With .Parent.ChartObjects.Add(.Left, .Top, .Width, .Height).Chart 'création nouveau graph temporaire (pour méthode Export)

Application.Wait (Now + TimeSerial(0, 0, 1))

.Paste

.ChartArea.Format.Line.Visible = msoFalse

.Export Filename

End With

ExportShapeToJPG = True

J'ai ensuite modifier (après de nombreuses tentatives!!!) le programme de façon à ce que le logo aille s'insérer dans la feuille "Présentation" et non dans la feuille "Logo" comme initialement programmé.

Ci joint le programme complet ayant été adapté. il fonctionnement en mode pas à pas. Il y aura peut être du ménage à faire :

Sub Test()
InsertSign Worksheet:=Worksheets("Logo"), Shape:=Sheets("Logo").Shapes("monlogo"), Height:=57, Width:=54.75
End Sub

Sub InsertSign(Worksheet As Worksheet, Shape As Shape, Height As Single, Width As Single)
Dim Filename$, msg$
If Height <= 0 Or Width <= 0 Or Height >= 1000 Or Width >= 1000 Then msg = "Les dimensions renseignées sont incorrectes.": GoTo fin
Filename = Environ("userprofile") & "\Desktop\a1z2e3r4t5y6.jpg"

If ExportShapeToJPG(Shape, Filename) Then
Sheets("Présentation").Select
    ActiveSheet.PageSetup.LeftHeaderPicture.Filename = _
        Environ("userprofile") & "\Desktop\a1z2e3r4t5y6.jpg"
    With ActiveSheet.PageSetup.LeftHeaderPicture
        .Height = 28.5
        .Width = 24.75
    End With
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = "&G"
        .CenterHeader = "Présentation"
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.7)
        .RightMargin = Application.InchesToPoints(0.7)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With

Else
    msg = "Une erreur est survenue lors de l'insertion de la signature."
End If
If Dir(Filename) <> "" Then Kill Filename
fin:
If msg <> "" Then MsgBox msg, vbInformation
End Sub

Public Function ExportShapeToJPG(Forme As Shape, Filename As String) As Boolean

Sheets("Logo").Select
ActiveWindow.DisplayGridlines = False 'cacher ou afficher les lignes de grille
On Error GoTo fin
With Forme
    .CopyPicture Appearance:=xlScreen, Format:=xlPicture 'Copier dans le Presse-papier
    With .Parent.ChartObjects.Add(.Left, .Top, .Width, .Height).Chart 'création nouveau graph temporaire (pour méthode Export)
 Application.Wait (Now + TimeSerial(0, 0, 1))
        .Paste
        .ChartArea.Format.Line.Visible = msoFalse
        .Export Filename
    End With
    ExportShapeToJPG = True
fin:
    If .Parent.ChartObjects.Count > 0 Then .Parent.ChartObjects(.Parent.ChartObjects.Count).Delete
End With
ActiveWindow.DisplayGridlines = True
End Function

Encore merci pour le travail déjà effectué

Claude

Bonjour Claude,

Je vous remercie pour ce retour détaillé, c'est plaisant de voir un tel investissement !

Je ne suis pas sûr qu'il faille dénaturer le code de la sorte, d'autant qu'il n'y a plus lieu maintenant (à moins d'un bug ou d'un dysfonctionnement) de l'exécuter au pas à pas.

La sélection de la feuille ne me parait pas nécessaire. C'est à voir mais le problème soulevé laisse penser à un échec de la copie ou de la conservation dans le presse-papier. Je referai des essais quand j'aurais un peu de temps mais ça a bien marché la première fois.

Il faut savoir aussi que l'affectation de certaines propriétés de l'objet .pagesetup peut avoir un impact sur d'autres (c'est le cas de .zoom par exemple).

Dans le code, essayez ainsi :

Sub InsertSign(Worksheet As Worksheet, Shape As Shape, Height As Single, Width As Single)
Dim Filename$, msg$
If Height <= 0 Or Width <= 0 Or Height >= 1000 Or Width >= 1000 Then msg = "Les dimensions renseignées sont incorrectes.": GoTo fin
Filename = Environ("userprofile") & "\Desktop\a1z2e3r4t5y6.jpg"
If ExportShapeToJPG(Shape, Filename) Then
    With Worksheet.PageSetup
        .centerheader = .parent.name 'avant leftheader au cas où
        With .LeftHeaderPicture
            .Filename = Filename
            .Height = Height
            .Width = Width
        End With
        .LeftHeader = "&G"
    End With
Else
    msg = "Une erreur est survenue lors de l'insertion de la signature."
End If
If Dir(Filename) <> "" Then Kill Filename
fin:
If msg <> "" Then MsgBox msg, vbInformation
End Sub

Sinon, et c'est une idée que je n'ai pas exprimée mais que j'ai pensée directement, il pourrait être beaucoup plus simple d'avoir le fichier JPG sur le PC et de se passer de l'étape intermédiaire de création du JPG...

Cdlt,

Bonjour,

Merci pour ces retours;

Le fait d'avoir l'image sur le PC serait effectivement la meilleur solution, mais ce bout de programme s'intégrera dans un autre code avec plusieurs feuilles.
Il devra aussi fonctionner sur différents PC, les logos ne seront pas tous les mêmes. C'est pour cela que l'idée de bas me va bien.

J'ai essayé la solution proposée, mais le dysfonctionnement persiste à savoir:

Tout fonctionne en pas à pas, mais en automatique l'image n'à pas le temps de se coller sur le bureau. On y retrouve un "écran blanc".

J'ai aussi de mon coté fait des recherches complémentaires et j'ai un bout de la réponse liée à ce dysfonctionnement qui semble venir d'une modification de prise en compte des données entre Excel 2010 et les versions supérieures. Nota, je dispose d'Excel 2019. Le point problématique serait le .parent…..

Ci joint une explication trouvé sur un forum mais je n'arrive pas à exploiter cette réponse sur votre programme

"Extrait d'une discussion sur un forum"

J'ai repris mon fichier d'origine dans lequel j'ai modifié ma routine de la façon suivante :

- ajout du vidage du presse-papier

- ajout de la boucle test IsClipboardFormatAvailable(14)<>0

- ajout de la boucle test .Chart.Pictures.Count<>0

- mais surtout, et je crois que la solution était là, ajout de .Parent

C'est ce dernier point qui constitue la vraie différence entre les deux codes, celui qui marchait sous Excel 2010 mais pas sous Excel 2016 et celui qui marche sous Excel 2016.

La question qui reste posée : Pourquoi cette différence ?

La nouvelle routine est donc :

Le code indiqué sur un autre forum est le suivant :

Sub CaptureImage(strChemin As String, strFichierNomPrefixe As String, intNum As Integer)
' Créé et sauvegarde l'image du Shape nommé "Groupe A"
' Paramètres :
' - strChemin = répertoire du fichier image créé
' - strFichierNomPrefixe = préfixe du nom du fichier image à créer
' - intNum = numéro de l'image

  ' Déclaration des variables
  Dim shpCadre As Shape, chtChart As Chart
  Dim strPictureNum As String, strPictureNom As String

  ' Définition des variables
  Set shpCadre = ActiveSheet.Shapes("Groupe A")
  strPictureNum = "000"
  Mid(strPictureNum, 4 - Len(Trim(CStr(intNum)))) = Trim(CStr(intNum))
  strPictureNom = strChemin & strFichierNomPrefixe & strPictureNum & ".png"

  ' Vidage du presse-papier
  With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With

  ' Création de l'image dans un chart, sauvegarde, suppression du chart et dégroupage des shapes
  With ActiveSheet
    Set chtChart = .ChartObjects.Add(0, 0, 1, 1).Chart
    shpCadre.CopyPicture
    Do: DoEvents: hPicAvail = IsClipboardFormatAvailable(14): Loop While hPicAvail = 0
    With chtChart
      With .Parent
        .Width = shpCadre.Width
        .Height = shpCadre.Height
        .Activate
        With .Chart
          .Paste
          Do: DoEvents: Loop While .Pictures.Count = 0
          .Export strPictureNom, "PNG"
          .Pictures(1).Delete
        End With
      End With
    End With
    .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
    .Shapes("Groupe A").Ungroup
    Set chtChart = Nothing
    Set shpCadre = Nothing
  End With

End Sub

Mais, je suis trop faible en compétence pour exploiter cette possibilité de solution sur votre code.

Cordialement

Claude

Bonjour Claude et bonne année,

J'ai essayé d'adapter mon code en fonction de celui que vous avez trouvé :

Private Declare Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As Integer) As Long '<<< en tête de module

Public Function ExportShapeToJPG(Forme As Shape, Filename as string) As Boolean
'adapté de : https://excel-malin.com/vba-astuces/excel-vers-jpg/
ActiveWindow.DisplayGridlines = False 'cacher ou afficher les lignes de grille
On Error GoTo fin
With Forme
    CreateObject("htmlfile").parentwindow.clipboardData.clearData "Text" 'vidage presse-papier
    .CopyPicture Appearance:=xlScreen, Format:=xlPicture 'Copier dans le Presse-papier
    Do: DoEvents: hPicAvail = IsClipboardFormatAvailable(14): Loop While hPicAvail = 0
    With .Parent.ChartObjects.Add(.Left, .Top, .Width, .Height).Chart 'création nouveau graph temporaire (pour méthode Export)
        .Paste
        Do: DoEvents: Loop While .Pictures.Count = 0
        .ChartArea.Format.Line.Visible = msoFalse
        .Export Filename
    End With
    ExportShapeToJPG = True
fin:
    If .Parent.ChartObjects.Count > 0 Then .Parent.ChartObjects(.Parent.ChartObjects.Count).Delete
End With
ActiveWindow.DisplayGridlines = True
End Function

Il y a donc 3 lignes supplémentaires placées aux mêmes endroits sachant qu'il faut a priori rajouter une déclaration en tête de module de la fonction

IsClipboardFormatAvailable

dont je n'ai pas vraiment connaissance pour le moment...

La ligne la plus importante semble tout de même être le dernier do ... while juste après la méthode .paste. C'est cet endroit qui serait le mieux susceptible de résoudre votre problème d'image mal collée.

Cdlt,

Bonjour,

Bonne année aussi.

Suite à ce code qui donne du fil à retordre ! , j'ai repositionné la ligne

IsClipboardFormatAvailable

comme suit :

Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As Integer) As LongPtr '<<< en tête de module
Sub Test()
InsertSign Worksheet:=Worksheets("Logo"), Shape:=Sheets("Logo").Shapes("monlogo"), Height:=57, Width:=54.75
End Sub

Sub InsertSign(Worksheet As Worksheet, Shape As Shape, Height As Single, Width As Single)
Dim Filename$, msg$
If Height <= 0 Or Width <= 0 Or Height >= 1000 Or Width >= 1000 Then msg = "Les dimensions renseignées sont incorrectes.": GoTo fin
Filename = Environ("userprofile") & "\Desktop\a1z2e3r4t5y6.jpg"

If ExportShapeToJPG(Shape, Filename) Then
    With Worksheet.PageSetup
        .CenterHeader = .Parent.Name 'avant leftheader au cas où
        With .LeftHeaderPicture
            .Filename = Filename
            .Height = Height
            .Width = Width
        End With
        .LeftHeader = "&G"
    End With
Else
    msg = "Une erreur est survenue lors de l'insertion de la signature."
End If
If Dir(Filename) <> "" Then Kill Filename
fin:
If msg <> "" Then MsgBox msg, vbInformation
End Sub

Public Function ExportShapeToJPG(Forme As Shape, Filename As String) As Boolean
ActiveWindow.DisplayGridlines = False 'cacher ou afficher les lignes de grille
On Error GoTo fin
With Forme
    CreateObject("htmlfile").parentwindow.clipboardData.clearData "Text" 'vidage presse-papier
    .CopyPicture Appearance:=xlScreen, Format:=xlPicture 'Copier dans le Presse-papier
    Do: DoEvents: hPicAvail = IsClipboardFormatAvailable(14): Loop While hPicAvail = 0
    With .Parent.ChartObjects.Add(.Left, .Top, .Width, .Height).Chart 'création nouveau graph temporaire (pour méthode Export)
        .Paste
        Do: DoEvents:
        Loop While .Pictures.Count = 0
        .ChartArea.Format.Line.Visible = msoFalse
        .Export Filename
    End With
    ExportShapeToJPG = True
fin:
    If .Parent.ChartObjects.Count > 0 Then .Parent.ChartObjects(.Parent.ChartObjects.Count).Delete
End With
ActiveWindow.DisplayGridlines = True
End Function

Malheureusement, on arrive de nouveau au même dysfonctionnement. La ligne . With parent… ne fonctionnant qu'en mode pas à pas.
En parcourant depuis plusieurs heures d'autres forum, une autre piste est abordée.

Citation du forum : Je rencontre le même problème avec Office 2016. Il semble que ce soit un problème de calendrier. Lorsque vous créez l'objet graphique et que vous pouvez y coller. Si je parcours le code, il fonctionne comme prévu et génère mon image. J'ai trouvé un correctif qui semble fonctionner : Pour une raison quelconque, la sélection de la forme parent du graphique avant d'appeler le collage corrige le problème.

Avec le code suivant qui est proposé

Function CopyRangeToPNG(ByRef rngImage As Range) As String
Dim vFilePath As Variant

rngImage.CopyPicture Appearance:=xlScreen, Format:=xlPicture

With rngImage.Parent.ChartObjects.Add( _
Left:=rngImage.Left, Top:=rngImage.Top, _
Width:=rngImage.Width + 2, Height:=rngImage.Height + 2)

With .Chart
.Parent.Select
.ChartArea.Format.Line.Visible = msoFalse
.Paste
With .Pictures(1)
.Left = .Left + 2
.Top = .Top + 2
End With
" export
.Export CStr(ThisWorkbook.Path & "ImageName.PNG")
End With
.Delete
End With
CopyRangeToPNG = ThisWorkbook.Path & "ImageName.PNG"

End Function

Si vous pourriez essayer d'adapter ce correctif, à votre code, je suis partant pour re-tester.
Cordialement
Claude

Bonjour Claude et merci,

Je suis sincèrement désolé mais j'avais préparé un vrai roman et j'ai été déconnecté avant de le poster (j'ai tout perdu). Je ne me sens pas de tout réécrire...

Je disais en substance qu'il pouvait être intéressant de passer par des variables :

- variable worksheet pour stocker la .parent de la forme

- variable chartobject lors de l'ajout :

set oChtObj = .parent.chartobjects(...) 'sans le chart !!!

- variable chart ensuite (on décompose notre ligne unique en 2) :

set oCht = oChtObj.chart

On peut aussi utiliser la méthode .activate de l'objet .chart, il faut s'assurer qu'on soit bien sur la feuille Logo à ce moment.

Mais surtout, je disais que c'est beaucoup de contournement pour rien :

- déclaration API et gestion du presse-papier, compilation conditionnelle,

- gestion des éventuelles particularités selon les versions,

- gestion ensuite des déprotections de feuille (puisqu'il faudrait manifestement activer la feuille logo)

Alors qu'on peut simplement charger le fichier dont la qualité sera meilleure. Un simple test suffit à tester l'existence et à prévenir voire contraindre l'utilisateur de remettre ou renommer le fichier.

Cdlt,

PS : J'avais aussi suggéré de tester le code avec des points d'arrêt placés aux endroits décisifs.

Bonjour,

Merci, je vais explorer ces pistes.

Cordialement

Claude

Bonjour,

Ci dessous un code qui récupère un shape et le copie colle dans l'entête d'une feuille :

Sub Entete()
    Set S = Feuil1.Shapes("Logo")
    S.CopyPicture xlScreen, xlBitmap
    With S.Parent.ChartObjects.Add(0, 0, S.Width, S.Height).Chart
        While .Shapes.Count = 0
            DoEvents
            .Paste
        Wend
        .Export "monimage.jpg", "jpg"
        .Parent.Delete
    End With
    With Feuil2.PageSetup
        .LeftHeaderPicture.Filename = "monimage.jpg"
        .LeftHeaderPicture.Width = 40
        .LeftHeaderPicture.Height = 40
        .LeftHeader = "&G"
    End With
    Kill "monimage.jpg"
End Sub

Si cela peut aider, fonctionnel sous Excel 2016.

@ bientôt

LouReeD

Edit : ajout des extension à monimage... Erreur détectée lors de l'essai sur Office 365, mais à part cela ça fonctionne également