• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

EMF Chart Export from Excel

mo-ca

New Member
Hi,
recently, Office 2016 in 64bit was rolled in my office and (of course) some things refuse to work out of the box. In this special case, the emf export macro of mine changed its usual behaviour. After upgrading the header the image quality of the exported image is significantly worse than it used to be. On the right hand side there is the "new" version and on the left the older one (click to enlarge).



The macro is:
Code:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As LongPtr, ByVal lpszFile As String) As Long
Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As LongPtr) As Long
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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 wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () 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 hemf As Long) As Long
#End If

Public Function fnSaveAsEMF(strFileName As String) As Boolean
Const CF_ENHMETAFILE As Long = 14

Dim ReturnValue As Long

  OpenClipboard 0

  ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName)

  EmptyClipboard

  CloseClipboard

  '// Release resources to it eg You can now delete it if required
  '// or write over it. This is a MUST
  DeleteEnhMetaFile ReturnValue

  fnSaveAsEMF = (ReturnValue <> 0)

End Functio

Sub SaveItToEMF()
  Dim sFileName As String
  Dim sCellCharacter As String
  Dim x As Integer

  Selection.Copy
 
  sFileName = InputBox("Enter filename for export:", "Export object", sFileName)
 
  For x = 1 To Len(sFileName)
  sCellCharacter = Mid(sFileName, x, 1)
  If sCellCharacter Like "[</*\?%öäüß]" Then
  sFileName = Replace(sFileName, sCellCharacter, "_", 1) ', Replaces all illegal filename characters with "_"
  End If
 
  If Asc(sCellCharacter) <= 32 Then
  sFileName = Replace(sFileName, sCellCharacter, "_", 1) ' Replaces all non printable characters with "_"
  End If
  Next

  sFileName = ActiveWorkbook.Path & "\..\Bilder\" & sFileName & ".emf"
 
  If fnSaveAsEMF(sFileName) Then
  MsgBox "Saved", vbInformation
  Else
  MsgBox "NOT Saved!", vbCritical
  End If

End Sub
Has someone solved this already or can help to finde the error? Due to the quality requirements, a change to bmp, png, gif is not and option and I need the pictures for my papers.

Thanks in advance
 

Attachments

Chihiro

Excel Ninja
Can you upload sample workbook? It'll be easier for us to trouble shoot and give you alternate solution if there is one.
 

mo-ca

New Member
Hi,
please find enclosed the example document. I want to extract the chart as emf.

I needed to remove some function calls (Refprop) so everyone can take a look at it.

Thanks so far!
 

Attachments

Chihiro

Excel Ninja
Hmm, this isn't likely due to code. But some setting that changed or got reset upon install/upgrade of Office. Or due to missing registry entry, caused by going from 32 to 64 bit install.

Check your registry using regedit.
See if you find entry for Graphics Filters under...
HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Shared Tools


If it is there, then check again in
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\ClickToRun\REGISTRY\MACHINE\Software\Microsoft\Shared Tools\

If it's missing from one, then back up registry and add entry to missing location.

Note: Path may differ slightly based on OS, Update stream etc. Check with your IT as well.
 

Chihiro

Excel Ninja
Good luck, hopefully someone else will chime in here. I typically don't deal with emf and not familiar with what's all required to deal with it.
 

Chihiro

Excel Ninja
Hmm? It has both export and import.
upload_2018-5-31_10-8-13.png


One workaround is to copy chart. Then open PowerPoint, go to home tab and click on paste drop down and choose Paste Special ->Picture (Enhanced Metafile).

Then right click on image, save as, emf.

If this works for you, I'll try and see if I can automate.
 

mo-ca

New Member
ok ... The registry key regarding these filters are quite mysterious for me. Especially why there is non present. I'm not quite sure what to add ...

Is there another vector format excel can export and word is able to import ?
 

Chihiro

Excel Ninja
If you need to paste to word. It's quite simple really. Just follow the same process I gave you for PowerPoint.

Here's sample code for exporting chart as EMF file, using Excel & PowerPoint.
Code:
Option Explicit
Sub Demo()
Dim ppt As Object, pr As Object
Dim sl As Object
Selection.Copy

With CreateObject("PowerPoint.Application")
    Set pr = .Presentations.Add
    Set sl = pr.Slides.Add(1, 11)
    sl.Shapes.PasteSpecial DataType:=2
    sl.Shapes(sl.Shapes.Count).Export "C:\Test\Test.emf", 5
    pr.Close
    .Quit
End With
End Sub
Note: Unlike Excel, PowerPoint allows EMF by default.
 

ErikG

New Member
I tried the approach (shown above) and was able to paste the excel chart into PowerPoint okay. However, the saved emf file did not contain the bars from the bar chart. Any ideas how I can do this better? Thanks very much!!

The approach I tried:
Code:
Dim ppt As Object, pr As Object
Dim sl As Object
Selection.Copy
...
With CreateObject("PowerPoint.Application")
    Set pr = .Presentations.Add
    Set sl = pr.Slides.Add(1, 11)
    sl.Shapes.PasteSpecial DataType:=2
    sl.Shapes(sl.Shapes.Count).Export "C:\Test\Test.emf", 5
    pr.Close
    .Quit
End With
End Sub
Example file and jpg images of the original chart and emf version saved.
 

Attachments

Chihiro

Excel Ninja
You are probably selecting wrong area of the chart object.

You could replace "Selection.Copy" with "ActiveChart.ChartArea.Copy"
 

ivanme

New Member
Your emf export solution works great, you can turn off the screen switch to ppt after the command Set pr = .Presentations.Add?
 
Top