Exporter un graphique en WMF par VBA

Le
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
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Michel Pierron
Le #4570241
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" %
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


Misange
Le #4570221
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" %
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






Michel Pierron
Le #4570161
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"
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" 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







Misange
Le #4570141
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"
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" 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









Michel Pierron
Le #4569971
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"
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"
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" 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











Daniel.j
Le #4567211
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" %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



Francois L
Le #4566511
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" %
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






Misange
Le #4566451
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

Francois L
Le #4565051
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" %
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






Michel Pierron
Le #4564871
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"
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" 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







Publicité
Poster une réponse
Anonyme