Trouble pasting a Word equation into Excel

Question

I want to paste equations from Word into Excel 2007. The following Excel VBA code achieves this:

Sub ExpandEqn(MyText As String)

Dim appWd As Word.Application
Dim docWd As Word.Document
Dim objRange As Word.Range
Dim objEq As OMath

Set FindActiveCell = Application.ActiveCell
GetRange = CStr(FindActiveCell.Address())
ActiveCell.Offset(1, 0).Activate
NextActiveCell = CStr(FindActiveCell.Address())

Set appWd = CreateObject("Word.Application")
appWd.Visible = False
Set docWd = appWd.Documents.Add
Set objRange = docWd.Application.Selection.Range
objRange.Text = MyText
docWd.Application.Selection.OMaths.Add objRange
docWd.Application.Selection.OMaths.BuildUp
docWd.Application.Selection.WholeStory
docWd.Application.Selection.Copy

Range(NextActiveCell).Select
ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)",Link:=False,DisplayAsIcon:=False

appWd.Quit (False)
Set docWd = Nothing
Set appWd = Nothing

End Sub

Unfortunately, the pasted equation is the width of the Word document with lots of empty space e.g.

Is it possible to paste in the equation alone, excluding the space? The image can be pasted as a bitmap and works just fine, however, I require an updated metafile.

Answer 1

Use this:

Sub ExpandEqn(MyText As String)
    Dim appWd As Word.Application
    Dim docWd As Word.Document
    Dim objRange As Word.Range
    Dim objEq As OMath
    Dim FindActiveCell As Range
    Dim intColumnWidth As Integer
    Dim intRowHeight As Integer

    Set FindActiveCell = Application.ActiveCell
    GetRange = CStr(FindActiveCell.Address())
    ActiveCell.Offset(1, 0).Activate
    NextActiveCell = CStr(FindActiveCell.Address())

    Set appWd = CreateObject("Word.Application")
    appWd.Visible = False
    Set docWd = appWd.Documents.Add
    Set objRange = docWd.Application.Selection.Range
    objRange.Text = MyText
    docWd.Application.Selection.OMaths.Add objRange
    docWd.Application.Selection.OMaths.BuildUp
    docWd.Application.Selection.WholeStory
    docWd.Application.Selection.Copy

    ActiveCell.Offset(1, 0).Activate
    NextActiveCell = CStr(FindActiveCell.Address())
    Range(NextActiveCell).Select
    intColumnWidth = Range(NextActiveCell).ColumnWidth
    intRowHeight = Range(NextActiveCell).RowHeight
    docWd.Application.Selection.Columns.Width = intColumnWidth
    docWd.Application.Selection.Rows.Height = intRowHeight

    ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False

I hope this helps you.