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

来源：互联网发布：ipad pro草图软件编辑：程序博客网时间：2024/04/28 03:43
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