Mettre une image contenue dans une feuille en entête de page (VBA) Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
l
lefab
Jeune membre
Jeune membre
Messages : 10
Inscrit le : 14 septembre 2019
Version d'Excel : 2013

Message par lefab » 14 septembre 2019, 21:15

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
Collage entête.xlsm
(92.85 Kio) Téléchargé 2 fois
Avatar du membre
78chris
Passionné d'Excel
Passionné d'Excel
Messages : 4'129
Appréciations reçues : 301
Inscrit le : 9 juillet 2017
Version d'Excel : 2010 à 2019 + 365

Message par 78chris » 14 septembre 2019, 23:09

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
Chris
Quand un homme a faim, mieux vaut lui apprendre à pêcher que de lui donner un poisson.
Confucius
l
lefab
Jeune membre
Jeune membre
Messages : 10
Inscrit le : 14 septembre 2019
Version d'Excel : 2013

Message par lefab » 15 septembre 2019, 07:43

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.
l
lefab
Jeune membre
Jeune membre
Messages : 10
Inscrit le : 14 septembre 2019
Version d'Excel : 2013

Message par lefab » 15 septembre 2019, 08:17

lefab a écrit :
15 septembre 2019, 07:43
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
Avatar du membre
78chris
Passionné d'Excel
Passionné d'Excel
Messages : 4'129
Appréciations reçues : 301
Inscrit le : 9 juillet 2017
Version d'Excel : 2010 à 2019 + 365

Message par 78chris » 15 septembre 2019, 09:18

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...
Chris
Quand un homme a faim, mieux vaut lui apprendre à pêcher que de lui donner un poisson.
Confucius
l
lefab
Jeune membre
Jeune membre
Messages : 10
Inscrit le : 14 septembre 2019
Version d'Excel : 2013

Message par lefab » 15 septembre 2019, 10:42

78chris a écrit :
15 septembre 2019, 09:18
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 :btres:
Avatar du membre
78chris
Passionné d'Excel
Passionné d'Excel
Messages : 4'129
Appréciations reçues : 301
Inscrit le : 9 juillet 2017
Version d'Excel : 2010 à 2019 + 365

Message par 78chris » 15 septembre 2019, 13:36

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
Chris
Quand un homme a faim, mieux vaut lui apprendre à pêcher que de lui donner un poisson.
Confucius
l
lefab
Jeune membre
Jeune membre
Messages : 10
Inscrit le : 14 septembre 2019
Version d'Excel : 2013

Message par lefab » 15 septembre 2019, 18:31

78chris a écrit :
15 septembre 2019, 13:36
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?
Collage entête new.xlsm
(400.3 Kio) Téléchargé 2 fois
Avatar du membre
78chris
Passionné d'Excel
Passionné d'Excel
Messages : 4'129
Appréciations reçues : 301
Inscrit le : 9 juillet 2017
Version d'Excel : 2010 à 2019 + 365

Message par 78chris » 15 septembre 2019, 18:58

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...
Chris
Quand un homme a faim, mieux vaut lui apprendre à pêcher que de lui donner un poisson.
Confucius
l
lefab
Jeune membre
Jeune membre
Messages : 10
Inscrit le : 14 septembre 2019
Version d'Excel : 2013

Message par lefab » 15 septembre 2019, 20:24

78chris a écrit :
15 septembre 2019, 18:58
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

Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message