Results 1 to 1 of 1

Thread: vba word graphic element export to emf picture?

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    4,262

    vba word graphic element export to emf picture?

    Code:
    How to export the graphic element components of WORD and convert them into EMF vector diagram format?
    
    Images exported with WORD VBA are equivalent to their positions in WORD documents by default.
    If a single graphic element is displayed in the upper left corner of an empty WORD, two pixels may be missing on the left side when exporting, and the width is 3600 pixels the same as my screen.
    I wonder if there is any way to export these elements into EMF vector diagram format, such as PPT,EXCEL or third-party software?
    
    I want to find a software that can generate simple vector graphic elements, export EMF format pictures, and then zoom in and out at will in VB6 without blurring.
    
    
    Code:
    Sub exportEMF()
    
    Dim i As Long
        Const adTypeBinary = 1
        '?????????
        Const adTypeText = 2
        Const adSaveCreateNotExist = 1
        Const adSaveCreateOverWrite = 2
        Dim oStream As Object
        Dim arr() As Byte
        Set oStream = VBA.CreateObject("adodb.stream")
        i = 1
        Dim oDoc As Document
        Set oDoc = Word.ActiveDocument
        Dim oSP As Shape
        Dim sPath As String
        sPath = oDoc.Path & "\"
     
        
        Dim oInLineSp As InlineShape
        With oDoc
            For Each oSP In .Shapes
                 
                oSP.Select
                MsgBox oSP.Type
                arr = Word.Selection.EnhMetaFileBits
                With oStream
                    .Open
                    .Type = adTypeBinary
                    .Write arr
                    .SaveToFile sPath & i & ".emf", adSaveCreateOverWrite
                    .Close
                End With
                'MsgBox "i:" & i
                i = i + 1
            Next
            For Each oInLineSp In .InlineShapes
                arr = oInLineSp.Range.EnhMetaFileBits
                With oStream
                    .Open
                    .Type = adTypeBinary
                    .Write arr
                    .SaveToFile sPath & "b" & i & ".emf", adSaveCreateOverWrite
                    .Close
                End With
                i = i + 1
            Next
        End With
        MsgBox "ok"
    End Sub
    Attached Images Attached Images    

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width