Ms-Office VBA-Lösungen


Grafiken aus Word-Dokumenten programmtechnisch extrahieren
(WD2000, WD2003)


Ein alter Wunsch ist es, in Word-Dokumenten eingefügte Grafiken ohne Zuhilfenahme des HTML-Exportfilters in der "Originalform" zu extrahieren, d.h. die Grafiken (Raster oder Vektorgrafik) in Form der ursprünglichen Dateien wieder zu erhalten.

Die Erfüllbarkeit dieses Wunsches hängt davon ab, in welcher Form die Grafiken eingefügt wurden bzw. wie sie Word-intern im Dokument gespeichert wurden. Die neueren Winword-Versionen verwenden dazu die "nativen" Formate PNG, JPG und GIF (Rastergrafik) sowie WMF und EMF für Vektorgrafik. Der Typ EMF (Enhanced Metafile) wird dabei auch als universeller Container für Grafik aller Art (auch Rastergrafik) verwendet, die z.B. über die Zwischenablage transportiert wurde und nicht eindeutig (wie z. B. bei einem Screenshot  über Alt-Druck) als Bitmap identifizierbar ist sowie für alle Grafik "Nachbearbeitungen" in Winword. Wurde die Grafik darüber hinaus  - bewusst oder unbewusst - als OLE-Objekt eingefügt, liegen die Grafikdaten in der Form, wie sie die Quellanwendung unterstützt, vor.

Speziell im Fall des EMF-Formats kann das "ursprüngliche" Rastergrafikformat (PNG, JPEG oder GIF) nicht mehr im Original erhalten werden,  da  EMF Rasterdaten als Device Independent Bitmap (DIB) hält. Glücklicherweise sind die Rastergrafikformate PNG und GIF "reversibel", d.h. bei der Umwandlung in DIB (wie in EMF enthalten) und zurück in GIF oder PNG ist der "Originalzustand" ohne Qualitätsverlust wieder verfügbar. Anders liegen die Verhängnisse beim "nicht reversiblen" JPG-Format , hier bringt die Umwandlung in DIB und zurück in JPG in jedem Fall einen - wenn auch kleinen - Qualitätsverlust mit sich.

Vereinfacht gesagt können aus Datei in den Formaten BMP, PNG, GIF, JPG eingefügte Rastergrafiken  ebenso wie (reine) Vektorgrafik in den Formaten WMF und EMF immer im Original entnommen werden. Wurde eine Rastergrafik Word-intern in EMF "konvertiert", kann das Originaldateiformat dagegen nicht mehr zurück gewonnen werden. Ein Qualitätsverlust tritt dabei allerdings nur auf, wenn die Originaldaten im JPG-Format vorlagen.

Wie funktioniert das Verfahren? Die Version WD2003 bietet zur VBA-technischen Entnahme von Grafik die Eigenschaft .EnhMetafileBits für das Range- und Selection-Objekt, welche den "rohen" EMF-Stream als Byte-Array liefert. Diese Eigenschaft ist nicht grundlegend neu, sie entspricht einer "Abkürzung" der in älteren Versionen  verfügbaren CopyAsPicture-Methode und der nachfolgenden Entnahme des EMF-Daten aus der Zwischenablage. Glücklicherweise verwenden WD2002 und höher  das so genannte "Dual Metafile Format", das neben den "alten" EMF-Records auch die neuen EMF+ (entsprechend GDI+ Befehlen) Records enthält. Winword verwendet dabei den EMF+ Record-Type Object (Image) als "Container" für die Originalbilddaten (Bitmap oder Metafile), wodurch es möglich ist, die Grafiken im Originalformat  - soweit verfügbar - zurück zu gewinnen.

Folgender VBA-Code zeigt ein Beispiel, wie man aus dem EMF-Stream von Winword die Original-Bilddateien - soweit dies möglich ist - zurückgewinnen kann Es sind zwei Prozeduren ("Makros") vorhanden, zum Export der selektierten Grafik sowie zum Export alle Grafiken aus dem aktuellen Dokument.  Wird die Grafik im Original nicht gefunden und im Metafile ein Bitmap erkannt, werden die Rastendaten (DIB) im PNG-Format exportiert. Für den DIB nach PNG-Export werden GDI+ Funktionen verwendet (GDI+ ist standardmäßig unter Windows 2000 und höher verfügbar).
 

Option Explicit

' (c) Wolfram, 3/2005, ergänzt: 5/2006
' Grafiken aus Winword-Dokumenten im Original exportieren.
' Nur für WD2002 und WD2003 unter Win2000/XP/2003
' Hinweis: GDI+/EMF+ Record Format ist nicht dokumentiert,
' Anpassungen können bei Versionsänderungen notwendig werden.

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 GetEnhMetaFileBits Lib "gdi32" _
  (ByVal hEMF As Long, ByVal cbBuffer As Long, lpbBuffer As Byte) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  (pDest As Any, pSource As Any, ByVal cbLength As Long)
Private Declare Function GdiplusStartup Lib "gdiplus" _
  (token As Long, GdiplusStartupInput As Any, GdiplusStartupOutput As Any) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" _
  (token As Long)
Private Declare Function GdipDisposeImage Lib "gdiplus" _
  (ByVal image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" _
  (ByVal image As Long, ByVal filename As Long, clsidEncoder As GUID, _
   encoderParams As Any) As Long
Private Declare Function GdipCreateBitmapFromGdiDib Lib "gdiplus" _
  (gdiBitmapInfo As Any, gdiBitmapData As Any, bitmap As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" _
   (ByVal str As Long, id As GUID) As Long

Private Const CF_ENHMETAFILE = 14
Private emf() As Byte, imgData() As Byte

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

Private Type GDIPLUSSTARTINPUT
  GdiplusVersion As Long
  DebugEventProc As Long
  SuppressBackgroundThread As Long
  SuppressExternalCodecs As Long
End Type

Private Type EmfRecord ' private emf-type
  id As Long
  len As Long
End Type

Private Type GDI_Comment ' private GDI type
  len As Long
  Type As Long
  data As Long
End Type

Sub ExportSelectedPicture()
  Dim idir As String
  idir = ActiveDocument.FullName & ".img"   ' Export-Verzeichnis
  If Len(ActiveDocument.path) = 0 Then
    MsgBox "Bitte zuerst das Dokument speichern": Exit Sub
  End If
  If Len(Dir(idir, vbDirectory)) = 0 Then MkDir idir '  create Dir
  ExportPicture Selection.Range, "Selection", idir
End Sub

Sub ExportAllPictures()
  Dim ish As InlineShape, sh As Shape, idir As String
  Dim rStory As Range, imgCount As Long
  
  idir = ActiveDocument.FullName & ".img"   ' Export-Verzeichnis
  If Len(ActiveDocument.path) = 0 Then
    MsgBox "Bitte zuerst das Dokument speichern": Exit Sub
  End If
  If Len(Dir(idir, vbDirectory)) = 0 Then MkDir idir '  create Dir

  With ActiveDocument
    For Each rStory In .StoryRanges ' all Inlineshapes
      For Each ish In rStory.InlineShapes
        imgCount = imgCount + 1
        ExportPicture ish.Range, "InlineShape" & imgCount, idir
        While Not (rStory.NextStoryRange Is Nothing)
          Set rStory = rStory.NextStoryRange
          imgCount = imgCount + 1
          ExportPicture ish.Range, "InlineShape" & imgCount, idir
        Wend
      Next ish
    Next rStory
    imgCount = 0
    For Each sh In .Shapes         ' all Shapes in main document range
      sh.Select: DoEvents: imgCount = imgCount + 1
      ExportPicture Selection.Range, "Shape" & imgCount, idir
    Next sh
    ' all Shapes in Headers and Footers (Bug: VBA Shaperange common to all..)
    For Each sh In .Sections(1).Headers(wdHeaderFooterPrimary).Shapes
      ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageHeader
      sh.Select: DoEvents: imgCount = imgCount + 1
      ExportPicture Selection.Range, "Shape" & imgCount, idir
    Next sh
  End With
  ActiveDocument.ActiveWindow.View.SeekView = wdSeekMainDocument
End Sub

Function ExportPicture(ByVal r As Range, ByVal s As String, ByVal basename As String)
  Dim pBMI As Long, pDIB As Long, ext As String, picType As Integer
  
  Erase imgData: Erase emf
  GetImage r
  If ExportEMFPlusImageData(pBMI, pDIB) Then
    CopyMemory picType, imgData(0), 2
    Select Case picType
      Case &HD8FF: ext = ".jpg"
      Case &H4947: ext = ".gif"
      Case &H5089: ext = ".png"
      Case &H1:    ext = ".emf"
      Case &HCDD7: ext = ".wmf"
      Case Else:   ext = ".bmp"    ' unknown
    End Select
    SaveRawImageData basename & "\" & s & ext  ' save native format
    If (ext = ".wmf" Or ext = ".emf") And pBMI <> 0 And pDIB <> 0 Then ' mf contains bitmap
      SaveMFBitmapAsPng basename & "\" & s, pBMI, pDIB    ' save as bitmap (png format)
    End If
    StatusBar = basename & "\" & s & " exportiert."
  Else
    r.Select:  MsgBox "Fehler beim Export von " & s
  End If
End Function

Function GetImage(ByVal r As Range)
  Dim hEMF As Long, n As Long
  
  If Val(Application.Version) >= 11 Then
    ' EnhMetaFileBits liefert für Office 11 den "rohen" EMF-stream
    emf = CallByName(r, "EnhMetaFileBits", VbGet): DoEvents
  Else
    ' für Office <=10 Ersatz über Clipboard. Vorsicht: In Office 11
    ' liefert CopyAsPicture nur eine EMF-Kopie, nicht den rohen Stream.
    r.CopyAsPicture
    If OpenClipboard(0&) Then
      hEMF = GetClipboardData(CF_ENHMETAFILE)
      CloseClipboard
    End If
    If hEMF Then
      n = GetEnhMetaFileBits(hEMF, 0, ByVal 0&)
      If n Then
        ReDim emf(n - 1)
        GetEnhMetaFileBits hEMF, n, emf(0)
      End If
    End If
  End If
End Function

Function ExportEMFPlusImageData(pBMI As Long, pDIB As Long) As Boolean
  ' aus dem EMF-Stream die GDI+ (EMF+) Image-Daten extrahieren
  ' GDI+ "zu Fuß"
  Dim pEMF As Long, lEmf As Long, n As Long, state As Long, pNext As Long
  Dim recEMF As EmfRecord, recEMFplus As GDI_Comment, pImgData As Long
  Dim nextblock As Boolean, pCmd As Long, imgtype As Long, toff As Long
  Dim WMFhdr As Long, WMFhsz As Integer, misalign As Boolean, big As Boolean
  Dim dib As Boolean, dibits As Long, bmi As Long, imgend As Boolean
  
  On Error Resume Next
  n = UBound(emf)
  If n < 7 Or Err <> 0 Then Exit Function
  Do
    CopyMemory recEMF, emf(pEMF), 8
    'Debug.Print Hex$(pEMF), Hex$(recEMF.id), Hex$(recEMF.len)
    Select Case state
      Case 0: ' header
        If recEMF.id <> 1 Or recEMF.len = 0 Then Exit Function ' wrong header
        state = 1
      Case 1: ' wait for GDI_COMMENT Begin Group
        If recEMF.id = 70 And recEMF.len > 23 Then
          CopyMemory recEMFplus, emf(pEMF + 8), 12
          If recEMFplus.type = &H43494447 And recEMFplus.data = 2 Then ' GDIC
            state = 2
          End If
        End If
      Case 2: ' wait for GDI_COMMENT EMF+ (GDI+) records
        If recEMF.id = 70 And recEMF.len >= 20 Then
          CopyMemory recEMFplus, emf(pEMF + 8), 12
          'Debug.Print "+", Hex$(recEMFplus.type), Hex$(recEMFplus.data)
          If (recEMFplus.type = &H2B464D45) And (Not imgend) Then ' GDI+ record
            pNext = pEMF + 16
            pCmd = recEMFplus.data
            Do While (pCmd And &HFFFF&) <> &H4008  ' wait for cmd Image
              CopyMemory n, emf(pNext + 4), 4  ' len of command
              pNext = pNext + n
              If pNext >= pEMF + recEMF.len Then Exit Do
              CopyMemory pCmd, emf(pNext), 4   ' next command
            Loop
            If (pCmd And &HFFFFFFF) = &H5004008 Then  ' cmd Image + Flags
              big = (pCmd And &H80000000) = &H80000000
              toff = IIf(big, pNext + 20, pNext + 16)
              If Not (big And nextblock) Then
                CopyMemory imgtype, emf(toff), 4
                If imgtype = 1 Then            ' bitmap
                  ReDim imgData(recEMF.len - toff - 24 + pEMF - 1)
                  CopyMemory imgData(0), emf(toff + 24), recEMF.len - toff - 24 + pEMF
                ElseIf imgtype = 2 Then        ' metafile
                  ReDim imgData(recEMF.len - toff - 12 + pEMF - 1): misalign = False
                  CopyMemory WMFhdr, emf(toff + 12), 4
                  CopyMemory WMFhsz, emf(toff + 12 + 22 + 2), 2
                  If WMFhdr = &H9AC6CDD7 Then  ' WMF APM Header?
                    misalign = WMFhsz <> 9     ' check Std WMF hdr misaling
                  End If
                  If misalign Then             ' correct GDI+ misalign-bug
                    CopyMemory imgData(0), emf(toff + 12), 22  ' APM header
                    CopyMemory imgData(22), emf(toff + 12 + 22 + 2), recEMF.len - toff - 12 + pEMF - 22 - 2
                    ReDim Preserve imgData(UBound(imgData) - 2)
                  Else
                    CopyMemory imgData(0), emf(toff + 12), recEMF.len - toff - 12 + pEMF
                  End If
                Else
                  Exit Do                            ' unknown type
                End If  ' imgtype
                If big Then nextblock = True Else imgend = True
              Else
                n = UBound(imgData)
                ReDim Preserve imgData(n + recEMF.len - &H20)
                CopyMemory imgData(n + 1), emf(pEMF + &H20), recEMF.len - &H20
              End If  ' not (big and next)
            End If ' cmd image
          ElseIf recEMFplus.type = &H43494447 And recEMFplus.data = 3 Then ' GDIC end
            Exit Do ' EMF+ group end
          End If
        ElseIf recEMF.id = 81 And recEMF.len >= 88 And (Not dib) Then ' EMR_StrechDibits
          dib = True
          CopyMemory n, emf(pEMF + 48), 4      ' BMIoffset (0x50)
          bmi = pEMF + n                       ' BIHdr
          CopyMemory n, emf(pEMF + 56), 4      '
          dibits = pEMF + n                    ' DIBits
        End If
    End Select
    pEMF = pEMF + recEMF.len
  Loop Until pEMF > UBound(emf)
  n = 0: n = UBound(imgData)
  If n = 0 Then  ' if image not found, copy enh metafile bits
    ReDim imgData(UBound(emf)): CopyMemory imgData(0), emf(0), UBound(emf) + 1
  Else: pDIB = dibits: pBMI = bmi
  End If
  ExportEMFPlusImageData = True
End Function

Function SaveRawImageData(ByVal filename As String)
  Dim f As Long
  f = FreeFile
  Open filename For Binary Access Write As f
  Put f, 1, imgData
  Close f
End Function

Function SaveMFBitmapAsPng(ByVal basename As String, ByVal pBMI As Long, ByVal pDIB As Long)
  Dim GDIPSI As GDIPLUSSTARTINPUT, GDIPLUSToken As Long
  Dim img As Long, r As Long, pngEncoder As GUID

  GDIPSI.GdiplusVersion = 1
  GdiplusStartup GDIPLUSToken, GDIPSI, ByVal 0
  If GDIPLUSToken = 0 Then Exit Function
  If 0 = GdipCreateBitmapFromGdiDib(emf(pBMI), emf(pDIB), img) Then
    CLSIDFromString StrPtr("{557cf406-1a04-11d3-9a73-0000f81ef32e}"), pngEncoder
    GdipSaveImageToFile img, StrPtr(basename & ".png"), pngEncoder, ByVal 0
  End If
  GdipDisposeImage img
  GdiplusShutdown GDIPLUSToken
End Function


Hinweis: In diversen Newsgroups finden sich Programmbeispiele, die denn über .EnnMetafilebits erhaltenen EMF-Stream einfach als BMP-Datei speichern. Gespeichert wird dabei jedoch das Metafile und nicht die eventuell enthaltene Bitmap-Grafik. Dass beim Öffnen einer derartigen "BMP"-Datei dennoch deren Inhalt (muss nicht der Originalgrafik entsprechen!) dargestellt wird, ist der Identifikation des Dateityps in Windows anhand des Headers  zu verdanken. Windows bemerkt am Header, dass es sich um ein Metafile handelt, auch wenn der Dateityp falsch gewählt wurde (BMP statt  EMF).

Anmerkung: Jeglicher kommerzielle Einsatz dieses VBA Programmcodes sowie eine anderweitige Publizierung ist nicht gestattet.


Wolfram Oestreicher, 31.05.2006