В Word2003 появилась возможность сохранять документ(диапазон) в EMF-формате, в данном примере сохраняем постранично весь документ.

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Function SaveAsEmf() As Boolean

Dim PageCount As Integer, CurPage As Integer, AcPane As Pane
Dim Emf() As Byte, MyFile As Integer, strPic As String

On Error GoTo errr

With ActiveDocument

    'количество страниц документа
    PageCount = .ComputeStatistics(wdStatisticPages)
    'переводим док. в режим разметки страницы
    ActiveWindow.View.Type = wdPrintView

    Set AcPane = .ActiveWindow.Panes(1)

    'пробегаем по всем страницам
    For CurPage = 1 To PageCount
        
        'в зависимости от № текущий страницы
        'копируем диапазон в массив
        Select Case CurPage
        Case 2 To PageCount - 1
            Emf = .Range(AcPane.Pages(CurPage).Breaks(1).Range.Start, _
            AcPane.Pages(CurPage + 1).Breaks(1).Range.Start).EnhMetaFileBits
        Case 1 'первая страница
            Emf = .Range(0, AcPane.Pages(2).Breaks(1).Range.Start).EnhMetaFileBits
        Case Else 'последняя страница
            Emf = .Range(AcPane.Pages(PageCount).Breaks(1).Range.Start, .Content.End).EnhMetaFileBits
        End Select
        
        'копируем содержимое байтового массива в строку
        strPic = Space(UBound(Emf) + 1)
        CopyMemory ByVal strPic, Emf(0), UBound(Emf) + 1
        
        MyFile = FreeFile

        'сохраняем текущую страницу
        Open "c:\TESTFILE" & CurPage & ".EMF" For Binary Access Write As #MyFile
          Put #MyFile, 1, strPic
        Close #MyFile
    
    Next
    
End With

SaveAsEmf = True

Exit Function

errr:
SaveAsEmf = False

End Function