(* Read this into a new notebook using Get["X:\mathematica\WordInsert.m"] *)
BeginWordInsert[path_] := Module[{},
   mmamacro = OpenWrite[path <> "\mma_insert.bas"];
   WriteString[mmamacro,
    "Attribute VB_Name = "NewMacros"nn", "Sub mma_insert()n",
    "Attribute Macro1.VB_ProcData.VB_Invoke_Func =
"Normal.NewMacros.mmaInsert"n",
    "'n", "' ", "mmaInsert1 Macron", "'n", "'n"];
   mmaInsertN = 1;
   pathMI = path;];
(* *)
EndWordInsert[] :=
  Module[{}, WriteString[mmamacro,"End Sub"]; Close[mmamacro]];
(* *)
WordInsertP[graphic_, title_:"  Caption", IMres_:300,
   fileType_: "png"] := Module[{},
   fileN =
    pathMI <> "\mmaEP" <> ToString[mmaInsertN] <> "." <> fileType;
   Export[fileN, graphic, ImageResolution -> IMres];
   WriteString[mmamacro, "Selection.TypeParagraphn",
    If[mmaInsertN > 1,
     "Selection.TypeParagraphnSelection.TypeParagraphn", ""],
    "Selection.InlineShapes.AddPicture FileName:= _n",
    """, fileN, "", ", "LinkToFile:=False, _n",
    "SaveWithDocument:=Truen",
    "Selection.ParagraphFormat.Alignment=wdAlignParagraphCentern",
"Selection.Start = Selection.Start-1n",
    "Selection.InsertCaption Label:="Figure" , _n",
    "Title:="  ", title,
    "", Position:=wdCaptionPositionBelow,ExcludeLabel:=0n",
    "Selection.ParagraphFormat.Alignment=wdAlignParagraphCentern",
    "'n"];
   mmaInsertN = mmaInsertN + 1;
   ];
(* *)
WordInsertT[graphic_, title_: "  Caption", IMres_: 300,
   fileType_: "png"] := Module[{},
   fileN =
    pathMI <> "\mmaEP" <> ToString[mmaInsertN] <> "." <> fileType;
   Export[fileN, graphic, ImageResolution -> IMres];
   WriteString[mmamacro, "Selection.TypeParagraphn",
    If[mmaInsertN > 1,
     "Selection.TypeParagraphnSelection.TypeParagraphn", ""],
    "Selection.InlineShapes.AddPicture FileName:= _n",
    """, fileN, "", ", "LinkToFile:=False, _n",
    "SaveWithDocument:=Truen",
    "Selection.ParagraphFormat.Alignment=wdAlignParagraphCentern",
"Selection.Start = Selection.Start-1n",
    "Selection.InsertCaption Label:="Table" , _n",
    "Title:="  ", title,
    "", Position:=wdCaptionPositionAbove,ExcludeLabel:=0n",
    "Selection.ParagraphFormat.Alignment=wdAlignParagraphCentern",
    "'n"];
   mmaInsertN = mmaInsertN + 1;
   ];
Print["n**You've loaded the WordInsert Package**nnTo start your
session, run "BeginWordInsert[path]", where the path string points
to your working directory.nnNote escape characters need to be used
in the path definition n(IE. "X:\\mathematica").nnWrapers
WordInsertP and WordInsertT are for inserting (P)lots and (T)ables
respectively.n The insert functions are of the form
WordInsert[graphic,title,ext], nwhere graphic is any Mathematica
graphic object and the title is the string used in Word for the
Figure or Table caption (needs to be in quotes).n ext is the file
extension defining the type of graphic output to use (IE. "png").n
nThis package writes a ".bas" file that can be inported into MS
Word.nAll Plots and Tables will be inserted with captions when
"mmainsert" macro is run in Word.nnTo end your WordInsert session and finalize the .bas file creation,n you
must execute the "EndWordInsert[]" function.nn
A typical run sequence:nnBeginWordInsert["X:\mathematica"]nWordInsertP[g1,title1]nWordInsertP[g2,title2]
WordInsertT[g3,title3]nEndWordInsert[]nn"]