XL 2013 api createmetafile ne fonctionne pas comme createenHmetafile

[patricktoulon]

Bonjour à tous
j'ai un soucis avec la sauvegarde directe d'un object (shape picture, etc..) en WMF sans passer par olecreatepictureindirect
si quelqu'un sait je prends

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function CopyMetaFileA Lib "gdi32" (ByVal hmf As LongPtr, ByVal lpFileName As String) As LongPtr
Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEmf As LongPtr) As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal Format As Long) As Long

'LA FONCTION POUR LE FORMAT WMF
Function copyObjToWmfFile(obj As Object, Optional cheminX = "")
    Dim hMeta As LongPtr, hCopy As LongPtr
    If cheminX = "" Then cheminX = ThisWorkbook.Path & "\captureObject.Wmf"
    ' Copier la shape au format Metafile
    OpenClipboard (0): EmptyClipboard: CloseClipboard
    obj.CopyPicture
    ' Récupérer l'image en Metafile dans le presse papier et le sauve vers un fichier
    If OpenClipboard(0) Then
       Debug.Print "available in clip : " & IsClipboardFormatAvailable(&H3)
       If IsClipboardFormatAvailable(&H3) = 0 Then MsgBox " pas de meta dans le clip": Exit Function
       hMeta = GetClipboardData(&H3) ' VF_METAFILE = 0x3 (format WMF)soit au format Hex "&H3"
        Debug.Print "Handle hMeta : " & hMeta
        If hMeta <> 0 Then hCopy = CopyMetaFileA(hMeta, cheminX) ' Copier l'EMF dans un fichier
        Debug.Print "hcopy : " & hCopy
        DeleteEnhMetaFile hCopy ' Libérer la mémoire
    End If
    CloseClipboard ' Fermer le presse-papiers
    copyObjToWmfFile = cheminX
End Function

Sub TestF()
    copyObjToWmfFile ActiveSheet.Shapes("boule"), Environ("userprofile") & "\DeskTop\wmfboule.wmf"
End Sub

 

[Dudu2]

Bonjour à vous,
Merci pour ces superbes fonctions !
Question: une fois une image EMF ou WMF extraite, que peut-on en faire ?
Y a des logiciels qui les utilisent ?

 

[jurassic pork]

Bonjour à vous,
Merci pour ces superbes fonctions !
Question: une fois une image EMF ou WMF extraite, que peut-on en faire ?
Y a des logiciels qui les utilisent ?

Hello Dudu2,
les images Emf ou Wmf vectoriels sont surtout utilisées comme cliparts c'est à dire pour servir d'illustration dans des logiciels comme powerpoint , publisher ou word. Le fait qu'on puisse les redimensionner sans dégradation est bien pratique. Par contre ils ne sont pas connus du Html qui leur préfère en vectoriel le format svg. A noter qu'on peut éditer ces images avec le logiciel gratuit Inkscape qui est capable de générer en sortie du wmf, de l'emf , du svg et même dans ce logiciel on peut simplifier "les chemins" ce qui réduit la taille des fichiers en sortie.
Ami calmant, J.P

 

[jurassic pork]

voila un sujet fini

pas tout à fait😉
J'ai essayé ton code sous Excel 2021 64 bits
1 - il y a des erreurs de compilations dans la fonction CopyBitmapPicture sur hCopy& et ret& -> mettre hCopy As LongPtr , ret As LongPtr
2 - la fonction copyObjToWmfFile2 ne crée pas de fichier
et à noter que la fonction copyxlPicture génére un emf et pas un wmf même si la forme contient un wmf.

 

[patricktoulon]

il me rend fou le très vieux cochon
pourquoi maintenant elle ne fonctionnerait pas???

après peut être que la bitmap oui comme elle est assez ancienne j'ai peu être mal converti en vba 7

quand a la copypicture non c'est bien un WMF elle est convertie par le dispatch dans oleacreatepictureindirect
tu n'a qu'a faire un setdataclipboard ipic et tu verra

 

[patricktoulon]

re

 

[jurassic pork]

Hello,
elle est bien jolie ton animation Patrick, mais quelle version d'Excel utilises-tu ? parce que moi aussi cela fonctionne sous un Excel 2016 32 bits mais pas sous un Excel 2021 64 bits.
et pour le copyxlPicture j'ai une preuve comme quoi il génére un emf et pas un wmf :
je visualise une forme contenant la couronne WMF originale dans un contrôle image de userform en chargeant le contrôle image par la fonction copyxlPicture :

 Preview.Image1.Picture = copyxlPicture(ActiveSheet.Shapes("ImageCom"), "d:\temp\couronneXlPict.emf")

et voici ce que j'obtiens en visualisation :

je retombe sur mon bug de quart d'image ( testé sur un Excel 2016 32 bits et un Excel 2021 64 bits sous Windows 11).
Si je regarde dans le fichier généré , il y a EMF en début de fichier mais surtout les dimensions d'image ont changé (je pense que c'est pour cela je n'ai qu'un quart d'image) par rapport à l'image originale. Il y a un rapport 1,66 (l'image EMF est 1,66 plus grande que la WMF) et comme par hasard cela correspond au rapport entre la résolution inscrite pour l'image originale (120ppp) et la résolution écran (72ppp).
Ami calmant, J.P

 

[patricktoulon]

ma fois moi je pige plus tu avais déjà ce soucis de quart de l'image au départ
je vois par pourquoi tu reviendrais mettre en cause autre chose
pour moi c'est cette image qui a un truc
sauve une shape que tu fait toi même et reload la dans le picture d'un control ActivX tu verra tu n'aura pas de soucis

après peut être que sur 2021 des params ont changé
mais moi je n'ai aucun problème
mais je suis étonné au boulot on a 2021 dans 365 et là aussi je n'ai pas de problème avec copyxlpicture
ni avec ta couronne original d'ailleurs et ni avec celle que j'ai rechargé sur le lien que nous a donné @fanch55

dans tout les cas la copyxlpicture est fait pour renvoyer un ipictureDisp de façon a pouvoir l'utiliser dans un activX directement en tant que .picture
l'object ipic peut être sauvé avec savepicture(object,chemin) bien entendu

chez moi 2007 vb6 2013 vba7 32 et 2016 64 ça fonctionne parfaitement bien et sur 3 pc différents

grâce à @Rheem qui a trouvé le truc ,nous avons maintenant la possibilité de sauver directement en WMF

donc si tu veux sauver utilise celle là si tu veux juste transférer dans le .picture d'un activX une shape ou tout autre object alors copyxlpicture à l’époque j'avais fait cette fonction rien que pour ça (pour avoir l'object d'une feuille en tant qu' image dans un activX tout en gardant les partie complétement transparente )
et surtout pour éviter d'utiliser l'usine a gaz de stephen bullen qui ne gérait pas la transparence d'ailleurs


donne moi l'image qui te pose problème tel qu'elle est
attention n'accepte pas la demie transparence

 

[patricktoulon]

mais je te l'accorde que pour l'extracteur dans les commentaire le WMF a des soucis
le wmf rentre bien dans le commentaire mais à l'extraction il y a corruption
cela dit on a déjà la réponse et les conclusion que l'on en a tiré
donc on le sait on fait avec
reste plus qu'a mettre des commentaires et conseils dans les fonctions pour diverses utilisations

on a un petit paquet de fonction bien utile avec chacune leur avantages et inconvénients

 

[jurassic pork]

en pièce jointe le fichier wmf original et le fichier généré par le TestA sous Excel 2021 64 bits Windows 11
Quand je regarde ces images dans msPaint Windows 11 dans Fichiers/Propriétés de l'image ils n'ont pas les mêmes dimensions et visuellement ça se voit aussi.
Tu m'as donné les versions d'Excel de tes Pc mais pas les O.S

 

[patricktoulon]

tu l'a fait avec quoi la testA?

 

[jurassic pork]

tu l'a fait avec quoi la testA?

avec ton code du testA et ta fonction tout ça avec ton code complet en ne changeant que la forme de départ (qui est une forme avec le wmf original) et la destination.

 

[patricktoulon]

ok je refais l'operation chez moi
résultat sans appel

le zip avec ton original et la copie avec copyxlpicture
code dans l'userform

Private Sub UserForm_Activate()
Image1.Picture = LoadPicture("C:\Users\patricktoulon\Desktop\couronneOri.wmf")
Image2.Picture = LoadPicture("C:\Users\patricktoulon\Desktop\courronetestB.wmf")
End Sub

peut être que tu a des soucis bien plus grave que ce que l'on pense
ca se situerait au niveau des api
en tout cas tu vois chez moi ça fonctionne

 

[jurassic pork]

ok je refais l'operation chez moi
résultat sans appel
Regarde la pièce jointe 1212683
le zip avec ton original et la copie avec copyxlpicture
code dans l'userform

Private Sub UserForm_Activate()
Image1.Picture = LoadPicture("C:\Users\patricktoulon\Desktop\couronneOri.wmf")
Image2.Picture = LoadPicture("C:\Users\patricktoulon\Desktop\courronetestB.wmf")
End Sub

peut être que tu a des soucis bien plus grave que ce que l'on pense
ca se situerait au niveau des api
en tout cas tu vois chez moi ça fonctionne

tant que tu ne me donneras pas les O.S sous lesquels tu travailles cela sera difficile de savoir où il y a des différences et on pourra faire et refaire les manips chacun de notre côté on aura pas les mêmes résultats. Et si d'autres personnes peuvent faire le test dans leur coin cela permettra peut être de cerner le problème.
Ton image TestB est une emf est a des dimensions encore plus grandes que ma testA

 

[patricktoulon]

par contre celle sauvegarder avec copyObjToWmfFile2(issue de la methode de Rheem) ne passe pas dans les activX

 

[patricktoulon]

je te l'ai dit déjà
W7 et office 2007 sur vieux pc portable perso heu....jurassicPC + de 17 ans
W10 et office 2013 pro plus sur mon PC :il a 3 ans
W10 et office 2016 sur PC portable du boulot :il a 5 ans
W11 365 excel 2021 sur pc fixe du boulot: 1 ans même pas

les 4 je n'ai pas de soucis avec copyXlPicture