Mettre une image contenue dans une feuille en entête de page (VBA)

bonsoir à tous.

est - il possible de mettre une image "x" contenue dans une feuille en entête? Étant vraiment débutant en VBA, je ne trouve pas de solution pour référer l'image à l'entête à partir du bout de code trouvé en ligne.

par ailleurs, j'arrive à le faire si le fichier est stocké sur mon ordinateur. ci - joint le fichier d'essai avec le code dans le workbook

merci d'avance pour vos interventions

23collage-entete.xlsm (92.85 Ko)

Bonjour

adresse du fichier doit être remplacé par le chemin et le nom du fichier temporaire de même que MonImage et fichier plus loin

Pour simplifier :

Sub ImageLeftHeaderPicture()
Dim sh As Object
Dim shp As Object
MonImage = "T:\TEMP\MonImage.jpg"
Set shp = Sheets("image").Shapes(1)
Set sh = ActiveSheet
shp.Copy
Application.ScreenUpdating = False
    'Définit le nom et le lieu de stockage de l'image
    Sheets("image").Activate

    'Colle l'image dans un graphique
    With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage, "JPG"
    End With

    'Supprime le graphique
    With ActiveSheet
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
    End With

    sh.Activate
       With ActiveSheet.PageSetup
        .LeftHeaderPicture.Filename = MonImage
        .LeftHeaderPicture.Height = 150
        .LeftHeaderPicture.Width = 150
        .LeftHeader = "&G"
        .LeftFooterPicture.Filename = MonImage
        .LeftFooterPicture.Height = 40
        .LeftFooterPicture.Width = 40
        .LeftFooter = "&G"
        .CenterFooter = ActiveSheet.Cells(2, 2).Value
        .RightFooter = "&P de &N"
        End With

Kill MonImage
Application.ScreenUpdating = True
End Sub

Merci 78chris pour ta réponse, pour l'adresse du fichier j'avais compris mais pour la bout du code sur l'entête, non. je teste ça et je te fais signe.

maintenant, j'ai une inquiétude: vu que le but de la manœuvre est qu'en cas de changement de machine, que le fichier soit toujours disponible afin d'être ajouté en entête si elle venait à être changé intentionnellement ou pas, est ce que ce code assurera?

je teste et je vous retourne les résultats.

Merci 78chris pour ta réponse, pour l'adresse du fichier j'avais compris mais pour la bout du code sur l'entête, non. je teste ça et je te fais signe.

maintenant, j'ai une inquiétude: vu que le but de la manœuvre est qu'en cas de changement de machine, que le fichier soit toujours disponible afin d'être ajouté en entête si elle venait à être changé intentionnellement ou pas, est ce que ce code assurera?

je teste et je vous retourne les résultats.

comme je m'y attendais, ça ne marche pas lorsqu'on change de machine, le but c'est de référer l'image contenue déjà dans l'onglet image en entête pour une transportabilité sans contrainte.

d'autres solutions? quitte à changer complètement le code

RE

Le code prend l'image de l'onglet, en fait un fichier temporaire, reconstruit l'en-tête et détruit le fichier temporaire donc peu importe la machine...

RE

Le code prend l'image de l'onglet, en fait un fichier temporaire, reconstruit l'en-tête et détruit le fichier temporaire donc peu importe la machine...

Ah oui ! quel idiot je fais. en fait le problème est au niveau de l'exportation du fichier vers le répertoire temporaire. en fait il n'existe tout simplement pas d'où l'erreur. j'ai ajouté un bout de code qui vérifie l'existence du dossier et le crée s'il n'existe pas et là tout est nickel.

merci à toi 78chris

RE

Il faut utiliser un dossier qui existe sur toute machine.

En principe sur C: mais les autorisations peuvent être limitées

On peut utiliser le dossier Temp de Windows qu'on peut récupérer de deux façons

Soit par API

Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
    (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Function GetTempDir() As String

Dim buffer As String * 256
Dim Length As Long
Length = GetTempPath(Len(buffer), buffer)
GetTempDir = Left(buffer, Length)

End Function

et on utilise alors une ligne de type DossTmp = GetTempDir

ou par FileSystemObject qui nécessite la référence Microsoft Scripting Runtime

    'Activer Microsoft Scripting Runtime

    Dim fso As FileSystemObject

    Set fso = New FileSystemObject

    DossTmp = fso.GetSpecialFolder(2)  'répertoire temp

RE

Il faut utiliser un dossier qui existe sur toute machine.

En principe sur C: mais les autorisations peuvent être limitées

On peut utiliser le dossier Temp de Windows qu'on peut récupérer de deux façons

Soit par API

Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
    (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Function GetTempDir() As String

Dim buffer As String * 256
Dim Length As Long
Length = GetTempPath(Len(buffer), buffer)
GetTempDir = Left(buffer, Length)

End Function

et on utilise alors une ligne de type DossTmp = GetTempDir

ou par FileSystemObject qui nécessite la référence Microsoft Scripting Runtime

    'Activer Microsoft Scripting Runtime

    Dim fso As FileSystemObject

    Set fso = New FileSystemObject

    DossTmp = fso.GetSpecialFolder(2)  'répertoire temp

reçu 78chris je garde ces codes sur la main au cas où. j'ai juste ajouté une ligne pour créer le dossier afin d'y coller les images et ça marche.

cependant je n'y comprends rien pour la suite de mon projet.

j'essaye en vain d'activer le code en cliquant juste sur une feuil3. A chaque fois la macro tourne en rond et excel fini par redémarrer. lorsque j'exécute la macro toute seule elle tourne sans problème. je te joins un fichier tu comprendras mieux. j'ai du mettre en commentaire la procédure d'appel pour pouvoir enregistré le fichier

autre remarque, en exécutant cette macro sur excel 2016, les images apparaissent toutes blanches, est ce un bug de 2016?

Bonjour

C'est le code de Worksheet_Activate qui appelle Protectcollageentête donc si tu remets sh.Activate dans cette procédure cela déclenche Worksheet_Activate...

Tu tournes en rond d'où le plantage

Il faudrait utiliser

call protectcollageentête(ActiveSheet) dans Worksheet_Activate

et

Sub Protectcollageentête(sh As Worksheet)
Dim shp As Object
Dim path As String
path = "C:\Temp\"
' vérifier l'existence de path'
If Dir(path, vbDirectory) <> vbNullString Then
' si n'existe pas le créer
Else
MkDir (path)
End If
MonImage1 = "C:\Temp\entete1.jpg"
MonImage2 = "C:\Temp\entete2.jpg"
MonImage3 = "C:\Temp\entete3.jpg"
Set shp1 = Sheets("image").Shapes(1)
Set shp2 = Sheets("image").Shapes(2)
Set shp3 = Sheets("image").Shapes(3)

shp1.Copy
Application.ScreenUpdating = False
    'Définit le nom et le lieu de stockage de l'image
    Sheets("image").Activate

    'Colle l'image dans un graphique
    With sh.ChartObjects.Add(0, 0, shp1.Width, shp1.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage1, "JPG"
    End With

    'Supprime le graphique
    With sh
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
    End With

    shp2.Copy
     With sh.ChartObjects.Add(0, 0, shp2.Width, shp2.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage2, "JPG"
    End With

    'Supprime le graphique
    With ws
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
    End With

    shp3.Copy
     With sh.ChartObjects.Add(0, 0, shp3.Width, shp3.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage3, "JPG"
    End With

    'Supprime le graphique
    With sh
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
    End With

    With sh.PageSetup
     .LeftHeaderPicture.Filename = MonImage3
     .LeftHeaderPicture.Height = 100
     .LeftHeaderPicture.LockAspectRatio = msoFalse
     .LeftHeaderPicture.Width = 150
     .LeftHeader = "&G"
     .RightHeaderPicture.Filename = MonImage2
     .RightHeaderPicture.Height = 150
     .RightHeaderPicture.Width = 150
     .RightHeader = "&G"
     .CenterHeaderPicture.Filename = MonImage1
     .CenterHeaderPicture.Height = 100
     .CenterHeaderPicture.Width = 100
     .CenterHeader = "&G"
     End With

Kill MonImage1
Kill MonImage2
Kill MonImage3

Application.ScreenUpdating = True
End Sub

Néanmoins je trouve lourding de déclencher cela à chqaue activation de la feuille.

Il faudrait gérer une variable static pour ne le faire qu'une fois...

Evite de citer le message précédent à chaque fois.

Les messages se suivent ici donc c'est inutile et consommateur de ressources...

Bonjour

C'est le code de Worksheet_Activate qui appelle Protectcollageentête donc si tu remets sh.Activate dans cette procédure cela déclenche Worksheet_Activate...

Tu tournes en rond d'où le plantage

Il faudrait utiliser

call protectcollageentête(ActiveSheet) dans Worksheet_Activate

et

Sub Protectcollageentête(sh As Worksheet)
Dim shp As Object
Dim path As String
path = "C:\Temp\"
' vérifier l'existence de path'
If Dir(path, vbDirectory) <> vbNullString Then
' si n'existe pas le créer
Else
MkDir (path)
End If
MonImage1 = "C:\Temp\entete1.jpg"
MonImage2 = "C:\Temp\entete2.jpg"
MonImage3 = "C:\Temp\entete3.jpg"
Set shp1 = Sheets("image").Shapes(1)
Set shp2 = Sheets("image").Shapes(2)
Set shp3 = Sheets("image").Shapes(3)

shp1.Copy
Application.ScreenUpdating = False
    'Définit le nom et le lieu de stockage de l'image
    Sheets("image").Activate

    'Colle l'image dans un graphique
    With sh.ChartObjects.Add(0, 0, shp1.Width, shp1.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage1, "JPG"
    End With

    'Supprime le graphique
    With sh
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
    End With

    shp2.Copy
     With sh.ChartObjects.Add(0, 0, shp2.Width, shp2.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage2, "JPG"
    End With

    'Supprime le graphique
    With ws
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
    End With

    shp3.Copy
     With sh.ChartObjects.Add(0, 0, shp3.Width, shp3.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage3, "JPG"
    End With

    'Supprime le graphique
    With sh
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
    End With

    With sh.PageSetup
     .LeftHeaderPicture.Filename = MonImage3
     .LeftHeaderPicture.Height = 100
     .LeftHeaderPicture.LockAspectRatio = msoFalse
     .LeftHeaderPicture.Width = 150
     .LeftHeader = "&G"
     .RightHeaderPicture.Filename = MonImage2
     .RightHeaderPicture.Height = 150
     .RightHeaderPicture.Width = 150
     .RightHeader = "&G"
     .CenterHeaderPicture.Filename = MonImage1
     .CenterHeaderPicture.Height = 100
     .CenterHeaderPicture.Width = 100
     .CenterHeader = "&G"
     End With

Kill MonImage1
Kill MonImage2
Kill MonImage3

Application.ScreenUpdating = True
End Sub

Néanmoins je trouve lourding de déclencher cela à chqaue activation de la feuille.

Il faudrait gérer une variable static pour ne le faire qu'une fois...

Evite de citer le message précédent à chaque fois.

Les messages se suivent ici donc c'est inutile et consommateur de ressources...

ok! après avoir utilisé le code tel que décrit, j'ai eu des erreurs au niveau des charts impossible de les créer car à l'intérieur il y avait encore activesheet que j'ai enlevé ça tourne maintenant sauf qu'il est impossible de sélectionner la feuil3 en question, la macro s’achevant sur la feuille image.

Private Sub Worksheet_Activate()
Call Protectcollageentête(ActiveSheet)
End Sub

Sub Protectcollageentête(sh As Worksheet)
Dim shp As Object
Dim path As String
path = "C:\Temp\"
' vérifier l'existence de path'
If Dir(path, vbDirectory) <> vbNullString Then
' si n'existe pas le créer
Else
MkDir (path)
End If
MonImage1 = "C:\Temp\entete1.jpg"
MonImage2 = "C:\Temp\entete2.jpg"
MonImage3 = "C:\Temp\entete3.jpg"
Set shp1 = Sheets("image").Shapes(1)
Set shp2 = Sheets("image").Shapes(2)
Set shp3 = Sheets("image").Shapes(3)

shp1.Copy
Application.ScreenUpdating = False
    'Définit le nom et le lieu de stockage de l'image
    Sheets("image").Activate

    'Colle l'image dans un graphique
    With sh.ChartObjects.Add(0, 0, shp1.Width, shp1.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage1, "JPG"
    End With

    'Supprime le graphique
    With sh
     '   .ChartObjects(Worksheet.ChartObjects.Count).Delete
        .ChartObjects.Delete
    End With

    shp2.Copy
     With sh.ChartObjects.Add(0, 0, shp2.Width, shp2.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage2, "JPG"
    End With

    'Supprime le graphique
    With sh
     '   .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
        .ChartObjects.Delete

    End With

    shp3.Copy
     With sh.ChartObjects.Add(0, 0, shp3.Width, shp3.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export MonImage3, "JPG"
    End With

    'Supprime le graphique
    With sh
     '   .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
        .ChartObjects.Delete

    End With

    With sh.PageSetup
     .LeftHeaderPicture.Filename = MonImage3
     .LeftHeaderPicture.Height = 100
     .LeftHeaderPicture.LockAspectRatio = msoFalse
     .LeftHeaderPicture.Width = 150
     .LeftHeader = "&G"
     .RightHeaderPicture.Filename = MonImage2
     .RightHeaderPicture.Height = 150
     .RightHeaderPicture.Width = 150
     .RightHeader = "&G"
     .CenterHeaderPicture.Filename = MonImage1
     .CenterHeaderPicture.Height = 100
     .CenterHeaderPicture.Width = 100
     .CenterHeader = "&G"
     End With

Kill MonImage1
Kill MonImage2
Kill MonImage3
Application.ScreenUpdating = True
End Sub

RE

Evite de citer le message précédent à chaque fois.

Les messages se suivent ici donc c'est inutile et consommateur de ressources...

Il y a tellement de redites dans ton code que j'en ai loupé...

EDIT code mis à jour

Il est totalement inutile d'activer l'onglet Image et on peut simplifier (éviter d'utiliser comme nom de variable un nom réservé du langage VBA comme path)

Sub Protectcollageentête(sh As Worksheet)
Dim shp As Object
Dim Chemin As String
Chemin= "C:\Temp\"
' vérifier l'existence de path'
If Dir(Chemin, vbDirectory) <> vbNullString Then
' si n'existe pas le créer
Else
MkDir (path)
End If
Chemin = "C:\Temp\entete"
Set Sh2 = Sheets("image")

Application.ScreenUpdating = False
For i = 1 To 3
    Set shp = Sh2.Shapes(i)
    shp.Copy

    'Colle l'image dans un graphique
    With Sh2.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export Chemin & i & ".jpg", "JPG"
    End With

    'Supprime le graphique
    With Sh2
        .ChartObjects(.ChartObjects.Count).Delete
    End With

Next i

With sh.PageSetup
    .LeftHeaderPicture.Filename = Chemin & "3.jpg"
    .LeftHeaderPicture.Height = 100
    .LeftHeaderPicture.LockAspectRatio = msoFalse
    .LeftHeaderPicture.Width = 150
    .LeftHeader = "&G"
    .RightHeaderPicture.Filename = Chemin & "2.jpg"
    .RightHeaderPicture.Height = 150
    .RightHeaderPicture.Width = 150
    .RightHeader = "&G"
    .CenterHeaderPicture.Filename = Chemin & "1.jpg"
    .CenterHeaderPicture.Height = 100
    .CenterHeaderPicture.Width = 100
    .CenterHeader = "&G"
End With

For i = 1 To 3
    Kill Chemin & i & ".jpg"
Next i

Application.ScreenUpdating = True
End Sub

RE

Evite de citer le message précédent à chaque fois.

Les messages se suivent ici donc c'est inutile et consommateur de ressources...

Il y a tellement de redites dans ton code que j'en ai loupé...

Il est totalement inutile d'activer l'onglet Image et on peut simplifier

Sub Protectcollageentête(sh As Worksheet)
Dim shp As Object
Dim path As String
path = "C:\Temp\"
' vérifier l'existence de path'
If Dir(path, vbDirectory) <> vbNullString Then
' si n'existe pas le créer
Else
MkDir (path)
End If
Chemin = "C:\Temp\entete"
Set Sh2 = Sheets("image")

Application.ScreenUpdating = False
For i = 1 To 3
    Set shp = Sh2.Shapes(i)
    shp.Copy

    'Colle l'image dans un graphique
    With Sh2.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
        .Paste
        'Sauvegarde temporaire de l'image du graphique au format jpg
        .Export Chemin & i & ".jpg", "JPG"
    End With

    'Supprime le graphique
    With Sh2
        .ChartObjects(.ChartObjects.Count).Delete
    End With

Next i

With sh.PageSetup
    .LeftHeaderPicture.Filename = Chemin & "3.jpg"
    .LeftHeaderPicture.Height = 100
    .LeftHeaderPicture.LockAspectRatio = msoFalse
    .LeftHeaderPicture.Width = 150
    .LeftHeader = "&G"
    .RightHeaderPicture.Filename = Chemin & "2.jpg"
    .RightHeaderPicture.Height = 150
    .RightHeaderPicture.Width = 150
    .RightHeader = "&G"
    .CenterHeaderPicture.Filename = Chemin & "1.jpg"
    .CenterHeaderPicture.Height = 100
    .CenterHeaderPicture.Width = 100
    .CenterHeader = "&G"
End With

For i = 1 To 3
    Kill Chemin & i & ".jpg"
Next i

Application.ScreenUpdating = True
End Sub

cool 78chris; c'est nickel à présent. grandement merci

RE

Tu ne lis pas ce que j'écris et tu persistes à citer pour rien !

J'ai édité mon poste et simplifié le code : c'est bien plus court et donc plus fiable

salut 78chris, bien sur que je lis ce que tu écris seulement lors du dernier post, je suis allé directement au code avant de lire ton message, donc c'est bon j'ai compris.

merci encore pour la simplification du code, c'est nickel ainsi. après avoir remplacé "path" par "Chemin", tout fonctionne à merveille sur n'importe quel poste. merci encore.

désolé pour la réponse en retard, j'étais en déplacement.

Rechercher des sujets similaires à "mettre image contenue feuille entete page vba"