Export selection of word document as an image file

 原文地址：http://www.spotlight-wissen.de/archiv/message/1665077.html

Option Explicit

' (c) Désirée und Wolfram, 3/2005
' Modifiziert: 11/2007 - Bilder mit runden Ecken versehen
' Bilder aus Winword im Originalformat exportieren.
' Nur für WD2002 und WD2003 unter Win2000/XP/2003/Vista.
'
' Änderung  3.11.2007: RundeEcken Shape Seitenverhältnis sperren
' Änderung  4.11.2007: Table Pictures Contextmenu hinzugefügt
' Änderung  4.11.2007: Inlineshape Position wird erhalten, Section Delete
' Änderung  5.11.2007: Bilder in Header/Footer unterstützen

Private Declare Function EmptyClipboard Lib "user32" () 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 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 Const CF_ENHMETAFILE = 14
Private emf() As Byte, imgData() As Byte

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

Function ExportSelectedPicture(Filename As String) As String
  Dim pBMI As Long, pDIB As Long, ext As String, picType As Integer, s As String

  On Error Resume Next
  Erase imgData: Erase emf
  GetImage Selection
  
  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 &H4D42: ext = "bmp"
      Case &H4949: ext = "tif"
      Case &H50A:  ext = "pcx"
      Case &H100:  ext = "tga"
      Case &HD0C5:  ext = "eps"
      Case &H2100:  ext = "cgm"
      Case Else:   ext = "bmp"
    End Select
    
    s = Filename & "." & ext
    If Len(Dir(s)) Then Kill s
    SaveRawImageData s
    ExportSelectedPicture = s
  Else
    MsgBox "Fehler beim Export des selektierten Bildes"
  End If
End Function

Function GetImage(ByVal r)
  Dim hEMF As Long, n As Long
  
  If Val(Application.Version) >= 11 Then
    ' EnhMetaFileBits liefert für Office 11 den raw EMF-stream
    ' Bug: Clipboard muss vorher geleert werden
    If OpenClipboard(0&) Then
      EmptyClipboard
      CloseClipboard
    End If
    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 raw 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
  
  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

Sub GrafikMitRundenEcken()
  Dim ils As InlineShape, fBaseName As String, fName As String
  Dim w As Single, h As Single, sh As Shape, sh1 As Shape
  Dim sr As Single, sa As Range, sl As Single, st As Single
  Dim sla As Long, srh As Long, srv As Long, szp As Long
  Dim swo As Long, sdb As Single, sdl As Single, sdr As Single, hf As HeaderFooter
  Dim sdt As Single, ssi As Long, swt As Long, n As Long, r As Range, s As Long
      
  fBaseName = Options.DefaultFilePath(wdTempFilePath) & "/~temppic"
  
  s = Selection.Information(wdActiveEndSectionNumber)
  Select Case Selection.StoryType ' HeaderFooter Shapes
    Case wdEvenPagesHeaderStory ' 6
      Set hf = ActiveDocument.Sections(s).Headers(wdHeaderFooterEvenPages)
    Case wdPrimaryHeaderStory ' 7
      Set hf = ActiveDocument.Sections(s).Headers(wdHeaderFooterPrimary)
    Case wdEvenPagesFooterStory ' 8
      Set hf = ActiveDocument.Sections(s).Footers(wdHeaderFooterEvenPages)
    Case wdPrimaryFooterStory '  9
      Set hf = ActiveDocument.Sections(s).Footers(wdHeaderFooterPrimary)
    Case wdFirstPageHeaderStory ' 10
      Set hf = ActiveDocument.Sections(s).Headers(wdHeaderFooterFirstPage)
    Case wdFirstPageFooterStory ' 11
      Set hf = ActiveDocument.Sections(s).Footers(wdHeaderFooterFirstPage)
  End Select
  
  Select Case Selection.type
    Case wdSelectionInlineShape
      Set ils = Selection.InlineShapes(1)
      w = ils.Width
      h = ils.Height
      fName = ExportSelectedPicture(fBaseName)
      If Len(fName) Then
        'n = Selection.Start - Selection.Paragraphs(1).Range.Start
        Selection.Delete
        If Selection.StoryType >= 6 And Selection.StoryType <= 11 Then
          Set sh = hf.Shapes.AddShape(msoShapeRoundedRectangle, 0, 0, w, h, Selection.Range)
          Set r = hf.Range
          r.SetRange Selection.Paragraphs(1).Range.Start, Selection.Start
          n = r.Characters.Count
        Else
          Set sh = ActiveDocument.Shapes.AddShape(msoShapeRoundedRectangle, 0, 0, w, h, Selection.Range)
          n = ActiveDocument.Range(Selection.Paragraphs(1).Range.Start, Selection.Start).Characters.Count
        End If
        sh.Fill.UserPicture fName
        sh.Line.Visible = msoFalse
        sh.LockAspectRatio = msoTrue
        sh.Select
        CommandBars.FindControl(id:=5934).Execute  ' Ersatz für ConvertToInlineshape
        If n Then  ' ILS war nicht zu nicht zu Absatzbeginn
          Selection.Cut
          Selection.MoveRight wdCharacter, n ' an vorherige Position schieben
          Selection.Paste
        End If
      End If
      
    Case wdSelectionShape
      Set sh1 = Selection.ShapeRange(1)
      w = sh1.Width
      h = sh1.Height
      sr = sh1.Rotation
      Set sa = sh1.Anchor
      sl = sh1.Left
      st = sh1.Top
      sla = sh1.LockAnchor
      srh = sh1.RelativeHorizontalPosition
      srv = sh1.RelativeVerticalPosition
      szp = sh1.ZOrderPosition
      swo = sh1.WrapFormat.AllowOverlap
      sdb = sh1.WrapFormat.DistanceBottom
      sdl = sh1.WrapFormat.DistanceLeft
      sdr = sh1.WrapFormat.DistanceRight
      sdt = sh1.WrapFormat.DistanceTop
      ssi = sh1.WrapFormat.Side
      swt = sh1.WrapFormat.type
      
      fName = ExportSelectedPicture(fBaseName)
      If Len(fName) Then
        sh1.Delete
        If Selection.StoryType >= 6 And Selection.StoryType <= 11 Then
          Set sh = hf.Shapes.AddShape(msoShapeRoundedRectangle, sl, st, w, h, sa)
        Else
          Set sh = ActiveDocument.Shapes.AddShape(msoShapeRoundedRectangle, sl, st, w, h, sa)
        End If
        sh.Fill.UserPicture fName
        sh.Line.Visible = msoFalse
        sh.LockAspectRatio = msoTrue
        sh.Rotation = sr
        sh.LockAnchor = sla
        sh.RelativeHorizontalPosition = srh
        sh.RelativeVerticalPosition = srv
        sh.WrapFormat.AllowOverlap = swo
        sh.WrapFormat.DistanceBottom = sdb
        sh.WrapFormat.DistanceLeft = sdl
        sh.WrapFormat.DistanceRight = sdr
        sh.WrapFormat.DistanceTop = sdt
        sh.WrapFormat.Side = ssi
        sh.WrapFormat.type = swt
      End If
  End Select
End Sub

Sub AddContextMenu1()
  Const myId = "RundeEckenGrafik"
  CustomizationContext = ThisDocument
  Dim c As CommandBarControl, CBname As Variant, cbx As Variant
  
  CBname = Array("Inline Picture", "Floating Picture", "Table Pictures")
  
  For Each cbx In CBname
    For Each c In Application.CommandBars(cbx).Controls
      If c.Tag = myId Then c.Delete: Exit For
    Next
    With Application.CommandBars(cbx).Controls.Add(msoControlButton, , , 4)
      .Tag = myId
      .Caption = "Grafik mit runden Ecken"
      .OnAction = "GrafikMitRundenEcken"
    End With
  Next cbx
End Sub

Grüße
Wolfram