Reduce file size for charts pasted from excel into word - vba

Question

I have been creating reports by copying some charts and data from an excel document into a word document. I am pasting into a content control, so i use ChartObject.CopyPicture in excel and ContentControl.Range.Paste in word. This is done in a loop:
Set ws = ThisWorkbook.Worksheets("Charts")
With ws
For Each cc In wordDocument.ContentControls
If cc.Range.InlineShapes.Count > 0 Then
scaleHeight = cc.Range.InlineShapes(1).scaleHeight
scaleWidth = cc.Range.InlineShapes(1).scaleWidth
cc.Range.InlineShapes(1).Delete
.ChartObjects(cc.Tag).CopyPicture Appearance:=xlScreen, Format:=xlPicture
cc.Range.Paste
cc.Range.InlineShapes(1).scaleHeight = scaleHeight
cc.Range.InlineShapes(1).scaleWidth = scaleWidth
ElseIf ...
Next cc
End With
Creating these reports using Office 2007 yielded files that were around 6MB, but creating them (using the same worksheet and document) in Office 2010 yields a file that is around 10 times as large.
After unzipping the docx, I found that the extra size comes from emf files that correspond to charts that are pasted in using VBA. Where they range from 360 to 900 KB before, they are 5-18 MB. And the graphics are not visibly better.
Even further, it seems to be related to the Chart Style. I created a new spreadsheet and inserted 7 data points and a corresponding 2D pie chart. With the default style, it copied as a 79 KB emf, and with style 26 it copies as a 10 MB emf. When I was using Office 2007, the chart would copy as a 700 KB emf. This is the code:
Sub CopyAndPaste()
ThisWorkbook.Worksheets("Charts").ChartObjects("Chart 1").CopyPicture Appearance:=xlScreen, Format:=xlPicture
GetObject(, Class:="Word.Application").ActiveDocument.Range.Paste
End Sub
I am able to CopyPicture with the format xlBitmap, and while that is somewhat smaller, it is larger than the emf generated by Office 2007 and noticeably poorer quality. Are there any other options for reducing the file size? Ideally, I would like to produce a file with the same resolution for the charts as I did using Office 2007. Is there any way that uses VBA only (without modifying the charts in the spreadsheet)? Any way I can easily copy as an object without linking the documents?

Answer 1

"It's an older code, sir, but it checks out."
It's an old question and I have an even older (possible) solution: you can compress your .EMF files as .EMZ by gzipping it. This will reduce your file size while keeping the image quality.
On VB6 I used zlib.dll and the code below. I renamed the function names to english but I kept all comments in portuguese:
Option Explicit
' Declaração das interfaces com a ZLIB
Private Declare Function gzopen Lib "zlib.dll" (ByVal file As String, ByVal mode As String) As Long
Private Declare Function gzwrite Lib "zlib.dll" (ByVal file As Long, ByRef uncompr As Byte, ByVal uncomprLen As Long) As Long
Private Declare Function gzclose Lib "zlib.dll" (ByVal file As Long) As Long
Private Declare Function Compress Lib "zlib.dll" Alias "compress" (ByRef dest As Any, ByRef destLen As Any, ByRef src As Any, ByVal srcLen As Long) As Long
Private Declare Function Uncompress Lib "zlib.dll" Alias "uncompress" (ByRef dest As Any, ByRef destLen As Any, ByRef src As Any, ByVal srcLen As Long) As Long
' Ler o conteúdo de um arquivo
Public Function FileRead(ByVal strNomeArquivo As String) As Byte()
Dim intHandle As Integer
Dim lngTamanho As Long
Dim bytConteudo() As Byte
On Error GoTo FileReadError
' Abrir o documento indicado
intHandle = FreeFile
Open strNomeArquivo For Binary Access Read As intHandle
' Obter o tamanho do arquivo
lngTamanho = LOF(intHandle)
ReDim bytConteudo(lngTamanho)
' Obter o conteúdo e liberar o arquivo
Get intHandle, , bytConteudo()
Close intHandle
FileRead = bytConteudo
On Error GoTo 0
Exit Function
FileReadError:
objLogger.GravarEvento "modZLib.FileRead: " & Err.Description & " (" & Err.Number & " - " & Err.Source & ")", logTipoEvento.Erro
End Function
'Compactar um arquivo com o padrão gzip
Public Sub FileCompress(ByVal strArquivoOrigem As String, ByVal strArquivoDestino As String)
Dim gzFile As Long
Dim bytConteudo() As Byte
On Error GoTo FileCompressError
' Ler o conteúdo do arquivo
bytConteudo = FileRead(strArquivoOrigem)
' Compactar o conteúdo
gzFile = gzopen(strArquivoDestino, "wb")
gzwrite gzFile, bytConteudo(0), UBound(bytConteudo)
gzclose gzFile
On Error GoTo 0
Exit Sub
FileCompressError:
objLogger.GravarEvento "modZLib.FileCompress:" & Err.Description & " (" & Err.Number & " - " & Err.Source & ")", logTipoEvento.Erro
End Sub

Answer 2

I've dealt with something like this before
Instead of using
Document.Range.Paste
Try Using
Document.Range.PasteSpecial DataType:= wdPasteMetafilePicture
or
Document.Range.PasteSpecial DataType:= wdPasteShape
This will paste the chart as a picture or drawing as opposed to an embedded excel object
Equivelant to using "Paste Special..." from the menu.
Other DataTypes are available
http://msdn.microsoft.com/en-us/library/office/aa220339(v=office.11).aspx

Answer 3

This is possibly happening because the .emf files are getting scaled incorrectly. Using PNG may resolve the size issue (as mentioned in the comments above), but will still be an issue because they will not be vector images.
If you use AddPicture to add images to your file, then the following page shows a solution wherein you can change the scale and reduce filesize from whatever default is being used. So it might solve your issue.
http://social.msdn.microsoft.com/Forums/en-US/f1c9c753-77fd-4c17-9ca8-02908debca5d/emf-file-added-using-the-addpicture-method-looks-bigger-in-excel-20072010-vs-excel-2003?forum=exceldev