- 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