Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Exporter un graphique en WMF par VBA

Exporter un graphique en WMF par VBA

11 réponses
Avatar
Francois L
Bonjour à tous,

Est-ce que quelqu'un saurait faire ça ?
Les classiques GIF, JPEG, etc. je sais mais j'aurais vraiment besoin de
créer des WMF !

Merci

--
François L
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2
Avatar
Michel Pierron
Bonjour François;
Essaie comme ceci:

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
If ThisWorkbook.Sheets(1).ChartObjects.Count = 0 Then Exit Sub
On Error GoTo SaveWmf_Error
Dim Img As ChartObject, hCopy&, fName$
For Each Img In ThisWorkbook.Sheets(1).ChartObjects
Img.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = "C:" & Img.Name & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Next Img
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

MP


"Francois L" a écrit dans le message de news:
%
Bonjour à tous,

Est-ce que quelqu'un saurait faire ça ?
Les classiques GIF, JPEG, etc. je sais mais j'aurais vraiment besoin de
créer des WMF !

Merci

--
François L


Avatar
Misange
Superbe, comme d'hab :-)


Attention cependant, je n'ai pas pu tester mais j'ai lu que dans excel
2007 wmf n'est plus supporté ? Celui qui disait cela ralait car il avait
des classeurs avec des dizaines de graphiques conservés au format wmf
dans excel et qu'il ne pouvait plus les voir avec excel 2007. Tu
confirmes Michel si tu as 2007 ?

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour François;
Essaie comme ceci:

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
If ThisWorkbook.Sheets(1).ChartObjects.Count = 0 Then Exit Sub
On Error GoTo SaveWmf_Error
Dim Img As ChartObject, hCopy&, fName$
For Each Img In ThisWorkbook.Sheets(1).ChartObjects
Img.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = "C:" & Img.Name & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Next Img
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

MP


"Francois L" a écrit dans le message de news:
%
Bonjour à tous,

Est-ce que quelqu'un saurait faire ça ?
Les classiques GIF, JPEG, etc. je sais mais j'aurais vraiment besoin de
créer des WMF !

Merci

--
François L






Avatar
Michel Pierron
Bonjour Misange;
Je ne sais pas, je n'ai pas Excel 2007; mais je ne vois pas pourquoi il y
aurait impossibilité, vu que le format metafile fait partie du système
Windows.

Bises;
MP

"Misange" a écrit dans le message de news:

Superbe, comme d'hab :-)


Attention cependant, je n'ai pas pu tester mais j'ai lu que dans excel
2007 wmf n'est plus supporté ? Celui qui disait cela ralait car il avait
des classeurs avec des dizaines de graphiques conservés au format wmf dans
excel et qu'il ne pouvait plus les voir avec excel 2007. Tu confirmes
Michel si tu as 2007 ?

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour François;
Essaie comme ceci:

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
If ThisWorkbook.Sheets(1).ChartObjects.Count = 0 Then Exit Sub
On Error GoTo SaveWmf_Error
Dim Img As ChartObject, hCopy&, fName$
For Each Img In ThisWorkbook.Sheets(1).ChartObjects
Img.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = "C:" & Img.Name & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Next Img
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

MP


"Francois L" a écrit dans le message de
news: %
Bonjour à tous,

Est-ce que quelqu'un saurait faire ça ?
Les classiques GIF, JPEG, etc. je sais mais j'aurais vraiment besoin de
créer des WMF !

Merci

--
François L







Avatar
Misange
C'était exactement la réflexion faite par celui qui se plaignait
tu trouves cela quelque part dans cette page :
http://www.edwardtufte.com/bboard/q-and-a-fetch-msg?msg_id02kk&topic_id=1

Qui a excel 2007 dans la salle pour tester ? ;-)
pas moi...

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour Misange;
Je ne sais pas, je n'ai pas Excel 2007; mais je ne vois pas pourquoi il y
aurait impossibilité, vu que le format metafile fait partie du système
Windows.

Bises;
MP

"Misange" a écrit dans le message de news:

Superbe, comme d'hab :-)


Attention cependant, je n'ai pas pu tester mais j'ai lu que dans excel
2007 wmf n'est plus supporté ? Celui qui disait cela ralait car il avait
des classeurs avec des dizaines de graphiques conservés au format wmf dans
excel et qu'il ne pouvait plus les voir avec excel 2007. Tu confirmes
Michel si tu as 2007 ?

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour François;
Essaie comme ceci:

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
If ThisWorkbook.Sheets(1).ChartObjects.Count = 0 Then Exit Sub
On Error GoTo SaveWmf_Error
Dim Img As ChartObject, hCopy&, fName$
For Each Img In ThisWorkbook.Sheets(1).ChartObjects
Img.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = "C:" & Img.Name & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Next Img
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

MP


"Francois L" a écrit dans le message de
news: %
Bonjour à tous,

Est-ce que quelqu'un saurait faire ça ?
Les classiques GIF, JPEG, etc. je sais mais j'aurais vraiment besoin de
créer des WMF !

Merci

--
François L









Avatar
Michel Pierron
Re Misange;
Oui, il faut vraiment xl2007 pour tester si le format wmf est toujours
présent dans le presse-papier lors d'une copie.
C'est bizarre, ils disent sur le lien que tu donnes que c'est à cause d'une
faille dans ce type de format qu'excel l'aurait volontairement abandonné,
hors, cette faille vient d'être corrigée par le récent correctif KB912919.

MP


"Misange" a écrit dans le message de news:

C'était exactement la réflexion faite par celui qui se plaignait
tu trouves cela quelque part dans cette page :
http://www.edwardtufte.com/bboard/q-and-a-fetch-msg?msg_id02kk&topic_id=1

Qui a excel 2007 dans la salle pour tester ? ;-)
pas moi...

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour Misange;
Je ne sais pas, je n'ai pas Excel 2007; mais je ne vois pas pourquoi il y
aurait impossibilité, vu que le format metafile fait partie du système
Windows.

Bises;
MP

"Misange" a écrit dans le message de news:

Superbe, comme d'hab :-)


Attention cependant, je n'ai pas pu tester mais j'ai lu que dans excel
2007 wmf n'est plus supporté ? Celui qui disait cela ralait car il avait
des classeurs avec des dizaines de graphiques conservés au format wmf
dans excel et qu'il ne pouvait plus les voir avec excel 2007. Tu
confirmes Michel si tu as 2007 ?

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour François;
Essaie comme ceci:

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
If ThisWorkbook.Sheets(1).ChartObjects.Count = 0 Then Exit Sub
On Error GoTo SaveWmf_Error
Dim Img As ChartObject, hCopy&, fName$
For Each Img In ThisWorkbook.Sheets(1).ChartObjects
Img.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = "C:" & Img.Name & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Next Img
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

MP


"Francois L" a écrit dans le message de
news: %
Bonjour à tous,

Est-ce que quelqu'un saurait faire ça ?
Les classiques GIF, JPEG, etc. je sais mais j'aurais vraiment besoin
de créer des WMF !

Merci

--
François L











Avatar
Daniel.j
Bonjour
Je viens de coller une image WMF dans une feuille excel 2007 sans probleme !
et je peux meme en changer la couleur !!!
alors ............ ?
Daniel

--
FAQ MPFE
FAQ du forum microsoft.public.fr.excel
http://dj.joss.free.fr/faq.htm


"Michel Pierron" a écrit dans le message de news:
%232gs$
Re Misange;
Oui, il faut vraiment xl2007 pour tester si le format wmf est toujours
présent dans le presse-papier lors d'une copie.
C'est bizarre, ils disent sur le lien que tu donnes que c'est à cause
d'une faille dans ce type de format qu'excel l'aurait volontairement
abandonné, hors, cette faille vient d'être corrigée par le récent
correctif KB912919.

MP



Avatar
Francois L
Bonjour François;
Essaie comme ceci: (...)


Bonsoir Michel,

Merci mille fois, depuis le temps que je rame sur ce truc. Je teste ça
demain sur ma config de boulot et je te fais un retour.

Ps pour Misange, je ne pourrai pas tester sur 2007, au boulot je suis
sur 2007-10 :-) mais si ça marche bien, ce que je crois ( apparemment y
compris sur 2007 d'après Daniel), ça mérite une entrée sur le Disciplus.

--
François L


Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
If ThisWorkbook.Sheets(1).ChartObjects.Count = 0 Then Exit Sub
On Error GoTo SaveWmf_Error
Dim Img As ChartObject, hCopy&, fName$
For Each Img In ThisWorkbook.Sheets(1).ChartObjects
Img.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = "C:" & Img.Name & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Next Img
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

MP


"Francois L" a écrit dans le message de news:
%
Bonjour à tous,

Est-ce que quelqu'un saurait faire ça ?
Les classiques GIF, JPEG, etc. je sais mais j'aurais vraiment besoin de
créer des WMF !

Merci

--
François L






Avatar
Misange
compris sur 2007 d'après Daniel), ça mérite une entrée sur le Disciplus.


C'était déjà rédigé ;-)
merci à Daniel du test

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Avatar
Francois L
Bonjour François;


Bonsoir Michel,

Testé sur XL97 + XP et sur XL2000 + Me. Dans les deux cas ça marche,
sans soucis et l'image obtenue est d'une qualité très correcte compte
tenu de son poids même si cela reste inférieur à ce que l'on obtient
avec un "copier image", "coller comme metafichier".

J'ai fait des modifs pour gérer la saisie d'un nom de fichier, coller
dans le répertoire du classeur actif et n'exporter que le graphique
actif, y compris s'il est sur une feuille graphique. Ca donne ce qui
suit, merci de me dire si tu y vois une co.....e.

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
On Error GoTo SaveWmf_Error
Dim hCopy&, fName$, cName$, pName$
pName = ActiveWorkbook.Path
cName = InputBox("Nom du fichier image (sans extension)")
ActiveChart.ChartArea.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = pName & "" & cName & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

--
François L






Essaie comme ceci:

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
If ThisWorkbook.Sheets(1).ChartObjects.Count = 0 Then Exit Sub
On Error GoTo SaveWmf_Error
Dim Img As ChartObject, hCopy&, fName$
For Each Img In ThisWorkbook.Sheets(1).ChartObjects
Img.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = "C:" & Img.Name & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Next Img
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

MP


"Francois L" a écrit dans le message de news:
%
Bonjour à tous,

Est-ce que quelqu'un saurait faire ça ?
Les classiques GIF, JPEG, etc. je sais mais j'aurais vraiment besoin de
créer des WMF !

Merci

--
François L






Avatar
Michel Pierron
Bonsoir François;

1- Il faut ajouter une ligne au cas ou l'utilisateur abandonne sur InputBox:
If cName = "" Then Exit Sub

2- Avec l'instruction ActiveChart.ChartArea.Copy, si aucun graphique n'est
sélectionné, cela engendrera une erreur de type 91. Pour éviter celà, tu
devrais modifier la gestion d'erreur pour en avertir l'utilisateur:
SaveWmf_Error:
If Err.Number = 91 Then
MsgBox "Aucun graphique n'est sélectionné !", 64
Else
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End If

3- Si tu souhaites une meilleure définition, tu peux essayer en modifiant
l'instruction de copie comme ceci:
ActiveChart.CopyPicture: OpenClipboard 0&


MP


"Francois L" a écrit dans le message de news:

Bonjour François;


Bonsoir Michel,

Testé sur XL97 + XP et sur XL2000 + Me. Dans les deux cas ça marche, sans
soucis et l'image obtenue est d'une qualité très correcte compte tenu de
son poids même si cela reste inférieur à ce que l'on obtient avec un
"copier image", "coller comme metafichier".

J'ai fait des modifs pour gérer la saisie d'un nom de fichier, coller dans
le répertoire du classeur actif et n'exporter que le graphique actif, y
compris s'il est sur une feuille graphique. Ca donne ce qui suit, merci de
me dire si tu y vois une co.....e.

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
On Error GoTo SaveWmf_Error
Dim hCopy&, fName$, cName$, pName$
pName = ActiveWorkbook.Path
cName = InputBox("Nom du fichier image (sans extension)")
ActiveChart.ChartArea.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = pName & "" & cName & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

--
François L






Essaie comme ceci:

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveAsMetafile()
If ThisWorkbook.Sheets(1).ChartObjects.Count = 0 Then Exit Sub
On Error GoTo SaveWmf_Error
Dim Img As ChartObject, hCopy&, fName$
For Each Img In ThisWorkbook.Sheets(1).ChartObjects
Img.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = "C:" & Img.Name & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Next Img
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

MP


"Francois L" a écrit dans le message de
news: %
Bonjour à tous,

Est-ce que quelqu'un saurait faire ça ?
Les classiques GIF, JPEG, etc. je sais mais j'aurais vraiment besoin de
créer des WMF !

Merci

--
François L







1 2