図形を拡張メタファイル形式で貼り付ける

Excel VBA

Excelで図形（テキストボックス）を多用した書類を作っていざ印刷してみると、印刷結果の図形の大きさが編集の見た目と全然違って困った。
たくさんのテキストボックスを直線でつないで関係性を表すための図だったけど、テキストボックスの大きさが変わってしまい、テキストボックス同士や直線との位置関係が崩れてしまう。
印刷プレビューで見てみると確かにレイアウトが崩れて表示される。編集中の画面はズレてない。
ということで調べてみた。図として貼り付けてやれば編集中の見た目と印刷プレビューが変わることがない、みたいな情報を見つけたのでやってみると、確かにズレなくなった。
しかし、問題が。テキストボックスはたくさん（数百個）ある。手で「形式を選択して貼り付け」なんてやってられない。
そんなこんなで、シート内の図形を、別のシートに拡張メタファイルで貼り付けるExcel VBAを書いたのでメモっとく。

' Book1.xlsm の Sheet1 にある図形を Sheet2 に拡張メタファイル形式で貼り付ける
Sub ShapeCopyEmf()
  Dim myShape As Variant
  Worksheets("Sheet2").Select
  For Each myShape In Workbooks("Book1.xlsm").Worksheets("Sheet1").Shapes
    myShape.Copy
    ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)"
    Selection.Top = myShape.Top
    Selection.Left = myShape.Left
  Next
End Sub