How to make Mathematica graphs in Microsoft Word independent from Mathematica?

Question

When I open a .docx file containing Mathematica graphs on a computer without Mathematica software installed, the graphs look corrupted. For example, PlotMarkers or FrameLabel looks differently. How can I keep these graphs looking as they were originally on a computer without Mathematica?

Answer 1

You create metafiles every time when you copy graphics from Mathematica FrontEnd and paste it in MS Word because it is native format for exchanging vector graphics under Windows. So your question is actually about corrupted metafiles in MS Word document opened on a machine without Mathematica fonts installed. This behavior is expected because unlike PDF and EPS formats metafiles do not allow font embedding.

In the case when you cannot simply install Mathematica fonts on another machine you can preliminarily convert all the glyphs to outlines in Mathematica before exporting. The simplest way is to apply the following function to the whole graph:

toOutlines =  ImportString[ExportString[#, "PDF"], "PDF", "TextOutlines" -> True] &

With this approach sometimes you may need to scale up your graphics in order to achieve good quality of the outlined text. Another drawback is that with the above very basic implementation all the glyphs will be outlined, not only the glyphs from Mathematica fonts.

I also strongly recommend against usage of the clipboard for transferring graphics on Windows, the reasons are explained in this answer of mine:

• "Transfer graphics from Mathematica to Word without loss of quality."

---

If your problem is just PlotMarkers in ListPlot (which by default are glyphs from a Mathematica font) you could convert to outlines only them or (much better) specify PlotMarkers explicitly as graphical primitives.

Another alternative is to insert into the Word document not a metafile (which you do by default by selecting graphics in the FrontEnd, copying and pasting in MS Word) but an EPS vector image with Mathematica fonts embedded in it. It is more difficult because both Mathematica's EPS export and MS Office EPS Import filter are rudimentary in an incompatible way and you will need to Export your graphics to PDF first, then use third-party software to create EPS level 2 file from the exported PDF. But it is worth the effort because this way allows you to achieve the best possible vector quality for printing/publication purposes. Here I discuss how to do it using free Poppler utilities for Windows, and here - using Adobe Illustrator or CorelDraw, further details can be found in this answer.

If you are concerned mainly with the on-screen appearance or the above methods give unsatisfactory results you always can revert to the good old raster image format as described in the other answer. Here is a modification of that palette which copies graphics with target width of 1000 pixels:

toclipboard3[] := 
  Module[{selection = NotebookRead[SelectedNotebook[]]},
   If[MemberQ[Hold[{}, $Failed, NotebookRead[$Failed]], selection],
    $Failed (*there was nothing selected*),
    CopyToClipboard[
     Rasterize[
      Notebook[{If[TrueQ@MemberQ[{Cell, CellGroup}, Head[selection]], 
         selection, Cell[BoxData[selection]]]}, 
       Options[SelectedNotebook[]]], "Image", RasterSize -> 1000]]]];
CreatePalette[Button["Copy 1000 pixel width", toclipboard3[]]]

Note however that due to abundance of bugs and shortcomings in the current implementation of Mathematica's graphical functionality sometimes increasing resolution results in significant changes in the appearance of graphics (see this answer for discussion). It is often preferred to Export graphics to PDF first, then use Adobe Acrobat (or another renderer) for rendering it with arbitrary resolution.

Answer 2

Update

It's probably easier to use Edit -> Copy As -> Bitmap from the menubar. Changing the magnification of the notebook will change the size of the image that gets sent to the clipboard

Previous answer

There's likely a better answer out there, but I use a hack of the SEUploader to do this.

toclipboard2[] := If[
  MemberQ[Hold[{}, $Failed, NotebookRead[$Failed]], 
  NotebookRead[SelectedNotebook[]]],
     $Failed, (* there was nothing selected *)
     Module[{tag},
        FrontEndExecute[
        FrontEndToken[FrontEnd`SelectedNotebook[], "CopySpecial" , 
        If[$OperatingSystem === "Windows", "MGF" , "TIFF" ]]];
           Catch[
             NotebookGet@ClipboardNotebook[] /.
                r_RasterBox :> Block[{},
           Throw[Image[First[r], "Byte" , ColorSpace -> "RGB"], tag] /; True];
             $Failed, tag
           ]
        ]
      ];
CreatePalette[Button["clip", toclipboard2[]]]

This is the relevant section (the original function name is rasterizeSelection2). I'm assuming you are on a Windows platform, so this function should work for you.

To use, execute the code, and a very small palette will appear. Highlight the cell you want to copy and click the "clip" button in the palette. Paste away.

Note: I do use this function blindly; I don't understand all the ins and outs. @Szabolics can perhaps chime in and suggest why this is a good/bad idea.

Answer 3

You may find setting this font option improves the appearance in Word:-

(* Take note of your original settings *)
originalsettings = Options[$FrontEnd, PrivateFontOptions]

(* Set not to use Mathematica-only fonts *)
SetOptions[$FrontEnd, PrivateFontOptions -> {"OperatorSubstitution" -> False}]

(* If you need to find your front end init file it should be here *)
FileNames["*init.m", FileNameJoin@
  Append[FileNameSplit@$UserBaseDirectory, "FrontEnd"], Infinity]