Export selection of word document as an image file(2)

Option Explicit

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 ExportEMFPlusImageData(pBMI As Long, pDIB As Long) As Boolean

' Extract EMF-Stream from GDI+ (EMF+) Image-Data

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) =

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 -

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 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

Sub ExportSelectionAsPicture()

If Selection Is Nothing Then 'Nothing was selected

MsgBox "Please select something to export!"

Exit Sub

End If

Dim pBMI As Long, pDIB As Long, ext As String, picType As Integer, s As String, Filename As String

Filename = InputBox("Please input the filepath and filename you want to save as", "Warning", "C:/mypic")

On Error Resume Next

Erase imgData: Erase emf

'Get image

' ---------------------

Dim hEMF As Long, n As Long

If Val(Application.Version) >= 11 Then

If OpenClipboard(0&) Then

EmptyClipboard

CloseClipboard

End If

emf = Selection.EnhMetaFileBits

DoEvents

Else

'Office <=10

Selection.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

'-------------------------

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

Open s For Binary Access Write As #1

Put #1, 1, imgData

Close #1

MsgBox "The selection has been Exported as """ & s & """!"

Else

MsgBox "Can't Export the Selection As picture format!"

End If

End Sub