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