Option Explicit

Private Declare Function OpenClipboard Lib "user32" ( _
   ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long

Private Const CF_METAFILEPICT =  3 
Private Declare Function IsClipboardFormatAvailable Lib "user32" ( _
   ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32" ( _
   ByVal wFormat As Long) As Long

Private Type METAFILEPICT
   mm As Long
   xExt As Long
   yExt As Long
   hMF As Long
End Type

Private Declare Function GetMetaFileBitsEx Lib "gdi32" ( _
   ByVal hMF As Long, ByVal nSize As Long, lpvData As Any) As Long
Private Declare Function SetWinMetaFileBits Lib "gdi32" ( _
   ByVal cbBuffer As Long, lpbBuffer As Byte, ByVal hdcRef As Long, _
   lpmfp As METAFILEPICT) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" ( _
   ByVal hEMF As Long, ByVal cbBuffer As Long, _
   lpbBuffer As Byte) As Long

Private Declare Function GlobalLock Lib "kernel32" ( _
   ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" ( _
   ByVal hMem As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" ( _
   Destination As Any, Source As Any, ByVal Length As Long)


Function CopyToEMF(ByVal FileName As String) As Boolean
 Dim hMetaFile As Long
 Dim lMFSize As Long
 Dim hMem As Long
 Dim mfp As METAFILEPICT
 Dim hEMF As Long
 Dim MetaFileBits() As Byte
 Dim nFile As Integer
 
 If IsClipboardFormatAvailable(CF_METAFILEPICT) =  0  Then Exit Function
 If OpenClipboard( 0 ) =  0  Then Exit Function
 hMetaFile = GetClipboardData(CF_METAFILEPICT)
 If hMetaFile Then
    hMem = GlobalLock(hMetaFile)
    CopyMemory mfp, ByVal hMem, Len(mfp)
    hMem = GlobalUnlock(hMem)
    
    lMFSize = GetMetaFileBitsEx(mfp.hMF,  0 , ByVal  0 &)
    If lMFSize Then
       ReDim MetaFileBits( 0  To lMFSize -  1 ) As Byte
       lMFSize = GetMetaFileBitsEx(mfp.hMF, lMFSize, MetaFileBits( 0 ))
       hEMF = SetWinMetaFileBits(lMFSize, MetaFileBits( 0 ),  0 , mfp)
       If hEMF Then
          lMFSize = GetEnhMetaFileBits(hEMF,  0 , ByVal  0 &)
          If lMFSize Then
             ReDim MetaFileBits( 0  To lMFSize -  1 ) As Byte
             lMFSize = GetEnhMetaFileBits(hEMF, lMFSize, MetaFileBits( 0 ))
             nFile = FreeFile
             Open FileName For Output As #nFile
             Close #nFile
             Open FileName For Binary As #nFile
             Put #nFile, , MetaFileBits
             Close #nFile
             CopyToEMF = True
          End If
       End If
    End If
 End If
 CloseClipboard
End Function


Sub SaveEquationsToEMF()
 Dim fld As Word.Field
 Dim nEquation As Long
 Dim sPath As String
 sPath = ActiveDocument.Path
 If Right$(sPath,  1 ) <> "\" Then sPath = sPath & "\"
 For Each fld In ActiveDocument.Fields
    If fld.OLEFormat.ClassType Like "Equation.*" Then
       nEquation = nEquation +  1 
       fld.Copy
       CopyToEMF sPath & "Eq" & nEquation & ".EMF"
    End If
 Next fld
End Sub