减少从excel粘贴到Word中的图表的文件大小

内容来源于 Stack Overflow,并遵循CC BY-SA 3.0许可协议进行翻译与使用

  • 回答 (2)
  • 关注 (0)
  • 查看 (14)

我一直通过将一些图表和数据从EXCEL文档复制到Word文档中来创建报告。我将粘贴到内容控件中,因此我使用ChartObject.CopyPicture在EXCEL和ContentControl.Range.Paste在言语中。这是在一个循环中完成的:

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

我可以复制格式的图片xlBitmap,虽然这有点小,但它比Office 2007生成的EMF要大,而且质量明显较差。是否有任何其他选项可以减少文件大小?理想情况下,我希望生成与使用Office 2007相同分辨率的图表文件。是否有任何方法只使用VBA(不修改电子表格中的图表)?我可以轻松地复制为一个对象而不链接文档吗?

提问于
用户回答回答于

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
用户回答回答于

我以前处理过这种事

而不是使用

Document.Range.Paste

试着使用

Document.Range.PasteSpecial DataType:= wdPasteMetafilePicture

Document.Range.PasteSpecial DataType:= wdPasteShape

扫码关注云+社区