将从excel粘贴的图表的文件大小减小为word

Question

我一直在通过将excel文档中的一些图表和数据复制到word文档来创建报表.我正在粘贴内容控件,所以我ChartObject.CopyPicture在excel和ContentControl.Range.Pasteword中使用.这是在循环中完成的:

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

使用Office 2007创建这些报告产生的文件大约为6MB,但在Office 2010中创建它们(使用相同的工作表和文档)会产生大约10倍的文件.

在解压缩docx之后,我发现额外的大小来自emf文件,这些文件对应于使用VBA粘贴的图表.它们的范围从360到900 KB之间,它们是5-18 MB.而且图形效果并不明显.

更进一步,它似乎与图表风格有关.我创建了一个新的电子表格并插入了7个数据点和相应的2D饼图.使用默认样式,它复制为79 KB emf,而使用样式26复制为10 MB emf.当我使用Office 2007时,图表将复制为700 KB emf.这是代码:

Sub CopyAndPaste()
    ThisWorkbook.Worksheets("Charts").ChartObjects("Chart 1").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    GetObject(, Class:="Word.Application").ActiveDocument.Range.Paste
End Sub

我能够使用格式的CopyPicture xlBitmap,虽然它稍微小一点,但它比Office 2007生成的emf大,质量明显更差.还有其他减少文件大小的选项吗？理想情况下,我想为使用Office 2007的图表生成一个具有相同分辨率的文件.有没有任何方法只使用VBA(不修改电子表格中的图表)？我可以轻松地复制为对象而无需链接文档？

Answer 1

\n

“这是一个较旧的代码，先生，但它可以检查出来。”

\n

\n\n

这是一个老问题，我有一个更旧的（可能的）解决方案：您可以通过 gzip 压缩 .EMF 文件将其压缩为 .EMZ 。这将减少文件大小，同时保持图像质量。

\n\n

在 VB6 上我使用了zlib.dll下面的代码。我将函数名称重命名为英语，但我保留了葡萄牙语的所有注释：

\n\n

Option Explicit\n\n\' Declara\xc3\xa7\xc3\xa3o das interfaces com a ZLIB\nPrivate Declare Function gzopen     Lib "zlib.dll" (ByVal file As String, ByVal mode As String) As Long\nPrivate Declare Function gzwrite    Lib "zlib.dll" (ByVal file As Long, ByRef uncompr As Byte, ByVal uncomprLen As Long) As Long\nPrivate Declare Function gzclose    Lib "zlib.dll" (ByVal file As Long) As Long\nPrivate 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\nPrivate 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\n\n\' Ler o conte\xc3\xbado de um arquivo\nPublic Function FileRead(ByVal strNomeArquivo As String) As Byte()\n\n    Dim intHandle     As Integer\n    Dim lngTamanho    As Long\n    Dim bytConteudo() As Byte\n\n    On Error GoTo FileReadError\n\n    \' Abrir o documento indicado\n    intHandle = FreeFile\n    Open strNomeArquivo For Binary Access Read As intHandle\n\n    \' Obter o tamanho do arquivo\n    lngTamanho = LOF(intHandle)\n    ReDim bytConteudo(lngTamanho)\n\n    \' Obter o conte\xc3\xbado e liberar o arquivo\n    Get intHandle, , bytConteudo()\n    Close intHandle\n\n    FileRead = bytConteudo\n\n    On Error GoTo 0\n    Exit Function\n\nFileReadError:\n\n    objLogger.GravarEvento "modZLib.FileRead: " & Err.Description & " (" & Err.Number & " - " & Err.Source & ")", logTipoEvento.Erro\n\nEnd Function\n\n\'Compactar um arquivo com o padr\xc3\xa3o gzip\nPublic Sub FileCompress(ByVal strArquivoOrigem As String, ByVal strArquivoDestino As String)\n\n    Dim gzFile        As Long\n    Dim bytConteudo() As Byte\n\n    On Error GoTo FileCompressError\n\n    \' Ler o conte\xc3\xbado do arquivo\n    bytConteudo = FileRead(strArquivoOrigem)\n\n    \' Compactar o conte\xc3\xbado\n    gzFile = gzopen(strArquivoDestino, "wb")\n    gzwrite gzFile, bytConteudo(0), UBound(bytConteudo)\n    gzclose gzFile\n\n    On Error GoTo 0\n    Exit Sub\n\nFileCompressError:\n\n    objLogger.GravarEvento "modZLib.FileCompress:" & Err.Description & " (" & Err.Number & " - " & Err.Source & ")", logTipoEvento.Erro\n\nEnd Sub\n

\n