您的位置：首页 > 其它

Export selection of word document as an image file

2008-10-25 15:43 393 查看

原文地址：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

内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理

标签：

相关文章推荐

新的分享

章节导航