Enregistrer un dessin au format .emf sous VBA

[LaurentTBT]

Bonjour à tous,

Cela faisait longtemps que je n'étais pas revenu sur XLD, même si je continue à consulter le site régulièrement.
Je vois avec beaucoup de plaisir qu'XLD continue à prendre de l'ampleur, qu'il y a de plus en plus d'accros, et que la première réunion de famille a eu lieu. Quel dommage de n'avoir pu y participer.

En tout cas, je félicite David qui ne cesse d'améliorer le site qui pourtant était déjà particulièrement performant.

Et pour tous les contributeurs, bravo, continuez et restez les mêmes...

Je me dis toujours qu'il faut que je trouve le temps de revenir faire plus régulièrement des petits coucous, et j'ai un peu honte de revenir ici de manière intéressée, car j'ai effectivement une petite question à poser pour gagner du temps pour un petit projet que je fais pour mon boulot.

Concrétement, je cherche à enregistrer des dessins que j'ai fait à partir de la barre d'outils 'dessins'. Je veux le faire par macro car j'en ai plusieurs, et pour chacun, je dois leur faire subir plusieurs rotation et les enregistrer à chaque fois en .emf (le format microsoft pour ces dessins, 'métafichier windows amélioré'). Ensuite, je les utilise dans des usf.

Pour le moment, je travail sous powerpoint qui, contrairement à excel, permet d'enregistre un dessin (clic droit, puis 'enregistrer en tant qu'image') Manuellement, cela fonctionne parfaitement.

J'ai essayé l'enregistreur de macro sous powerpiont, ce qui donne:

ActivePresentation.SaveAs FileName:='C:\\Mes documents\\Image1.emf', FileFormat:=ppSaveAsEMF, EmbedTrueTypeFonts:=msoFalse

Le problème: quand je l'exécute, il ne m'enregistre pas la simple image du dessin, comme en manuel, mais toute la diapo powerpoint.

D'où la question: comment enregistrer un shape au format .emf en VBA, directement sous excel si possible, mais même sous ppt, cela me ferait gagner énormément de temps.

Merci à tous.

Laurent.


PS1: j'ai essayé d'utiliser un code de MichelXLD pour une question proche, mais je n'ai pas réussi avec mon format:
Lien supprimé

PS2: transmettez un grand salut à José, je pense à lui.

 

[MichelXld]

bonjour mon cher ami Laurent

cela me fait plaisir d'avoir de te nouvelles . j'espere que tout va bien pour toi et ta famille


en ce qui concerne ta question , cette demo de michel Pierron pourra peut etre t'aider

http://www.excelforum.com/showthread.php?t=376319&highlight=SaveShapeAsMetafile


bonne journée
MichelXld

 

[myDearFriend!]

Bonjour Laurent, Michel,

Oui, très content également de te revoir parmi nous Laurent ! J'espère que tu vas bien.

Laurent, je pensais à toi, il n'y a encore pas très longtemps car j'avais mis dans une réponse un lien pointant sur ta Démo WebBrowser en section de téléchargement (et d'ailleurs, je recommence tellement ce fichier, entre autres, à compter pour moi ! )


Sinon, j'ai cherché également de mon côté mais je n'ai rien trouvé sans API. Alors je te livre quand même ce que j'ai trouvé chez F.Sigonneau, ce code de L.Longre :

'La procédure 'Exporte' exporte la sélection active (objet dessiné,
'plage de cellules, graphique...) dans un fichier EMF (Enhanced MetaFile =
'métafichier amélioré), l'équivalent des fichiers WMF sous Win9x.
'L Longre, mpfe
'============================================================

Private Declare Function OpenClipboard Lib 'User32' _
   (ByVal hwnd As Long) As Long

Private Declare Function CloseClipboard Lib 'User32' () As Long

Private Declare Function GetClipboardData Lib 'User32' _
   (ByVal uFormat As Long) As Long

Private Declare Function CopyEnhMetaFileA Lib 'Gdi32' _
   (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long

Private Declare Function DeleteEnhMetaFile Lib 'Gdi32' _
   (ByVal hdc As Long) As Long

'____________________________________________________________

Sub Exporte()

   Dim FichierEMF, Rep As Long

   Do
      FichierEMF = Application.GetSaveAsFilename('Test', _
        'Métafichier amélioré (*.emf),*.emf', , 'Exportation sous')
      If VarType(FichierEMF) = vbBoolean Then Exit Sub
      If Dir$(FichierEMF) <> '' Then
        Rep = MsgBox('Le fichier ' & FichierEMF & ' existe déjà. ' _
        & 'Désirez-vous le remplacer ?', vbYesNoCancel + vbQuestion)
        If Rep = vbCancel Then Exit Sub
        If Rep = vbYes Then
            Kill FichierEMF
            Exit Do
        End If
      Else
        Exit Do
      End If
   Loop
   If CopieFichierEMF(Selection, CStr(FichierEMF)) = '' Then
      MsgBox 'Erreur !', vbCritical
   Else
      MsgBox 'Sélection copiée dans le fichier' & FichierEMF & ' .'
   End If

End Sub

'____________________________________________________________

Private Function CopieFichierEMF(Objet As Object, _
   NomFichier As String, Optional Apparence, _
   Optional Format, Optional Taille) As String

   If TypeName(Objet) <> 'Chart' Then Objet.CopyPicture Apparence, _
      Format Else Objet.CopyPicture Apparence, Format, Taille
   OpenClipboard 0
   If DeleteEnhMetaFile(CopyEnhMetaFileA(GetClipboardData(14), _
      NomFichier)) = 0 Then CopieFichierEMF = '' _
      Else CopieFichierEMF = NomFichier
   CloseClipboard

End Function

A bientôt j'espère...

 

[LaurentTBT]

Hello, Michel et Didier,

ça, c'est du rapide!
J'ai déjà essayé la macro de Michel qui me convient parfaitement, et je jette un coup à celle de Didier aussi.

Grand merci à tous les deux. J'essaye de vous donner de plus amples nouvelles à l'occasion.

Laurent.