Office関連

[Excel VBA]PowerPointに表を貼り付けようとするとオートメーションエラーが発生

Excel Q&Aサロン(VBA)にExcelの表をPowerPointのスライドに貼り付けようとするとエラーが発生する、との質問がありました。

下記コードをPowerPoint 2010環境で実行して動作を確認してみると、たしかに一部の形式でオートメーション エラー(-2147188160 (80048240))が発生しました。

Public Sub Sample1()
  Dim prs As Object
  Dim lay As Object
  
  Const ppPasteDefault = 0
  Const ppPasteBitmap = 1
  Const ppPasteEnhancedMetafile = 2
  Const ppPasteMetafilePicture = 3
  Const ppPasteGIF = 4
  Const ppPasteJPG = 5
  Const ppPastePNG = 6
  Const ppPasteText = 7
  Const ppPasteHTML = 8
  Const ppPasteRTF = 9
  Const ppPasteOLEObject = 10
  Const ppPasteShape = 11
  
  ActiveSheet.Range("B2:D7").Copy
  With CreateObject("PowerPoint.Application")
    .Visible = True
    Set prs = .Presentations.Add
    Set lay = GetCustomLayout(prs, "白紙")
    If Not lay Is Nothing Then
      With prs.Slides.AddSlide(1, lay).Shapes
        .PasteSpecial ppPasteDefault 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPasteBitmap 'OK
        '.PasteSpecial ppPasteEnhancedMetafile 'OK
        '.PasteSpecial ppPasteMetafilePicture 'OK
        '.PasteSpecial ppPasteGIF 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPasteJPG 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPastePNG 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPasteText 'OK
        '.PasteSpecial ppPasteHTML 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPasteRTF 'OK
        '.PasteSpecial ppPasteOLEObject 'OK
        '.PasteSpecial ppPasteShape 'オートメーション エラー(-2147188160 (80048240))
      End With
    End If
  End With
End Sub

Private Function GetCustomLayout(ByVal TargetPresentation As Object, _
                                 ByVal LayoutName As String) As Object
  Dim ret As Object
  Dim c As Object
  
  For Each c In TargetPresentation.SlideMaster.CustomLayouts
    If c.Name = LayoutName Then
      Set ret = c
      Exit For
    End If
  Next
  Set GetCustomLayout = ret
End Function

PowerPoint_PasteSpecial_Error_01

引っ掛かるのは一部のDataTypeで、さらに手作業で貼り付け作業を行うとエラーが発生しないので、不可解な動作に思えます。

ただ、手作業で問題が無いのであれば、下記コードのように直接コマンドを実行(ExecuteMso)することで、エラーを回避することができます。

Public Sub Sample2()
  Dim prs As Object
  Dim sld As Object
  Dim lay As Object
  Dim r As Object, c As Object
  
  ActiveSheet.Range("B2:D7").Copy
  With CreateObject("PowerPoint.Application")
    .Visible = True
    Set prs = .Presentations.Add
    Set lay = GetCustomLayout(prs, "白紙")
    If Not lay Is Nothing Then
      Set sld = prs.Slides.AddSlide(1, lay)
      .CommandBars.ExecuteMso "PasteSourceFormatting"
      
      With sld
        '貼り付け待ち
        While .Shapes.Count < 1
          DoEvents
        Wend
        '----- 以下装飾 -----
        With .Shapes.Range(.Shapes.Count)
          .Width = 640
          .Height = 480
          .Align msoAlignCenters, True '左右中央揃え
          .Align msoAlignMiddles, True '上下中央揃え
          If .HasTable = True Then
            '各セルのフォントサイズ変更
            For Each r In .Table.Rows
              For Each c In r.Cells
                c.Shape.TextFrame2.TextRange.Font.Size = 24
              Next
            Next
          End If
        End With
        '--------------------
      End With
    End If
  End With
End Sub

Private Function GetCustomLayout(ByVal TargetPresentation As Object, _
                                 ByVal LayoutName As String) As Object
  Dim ret As Object
  Dim c As Object
  
  For Each c In TargetPresentation.SlideMaster.CustomLayouts
    If c.Name = LayoutName Then
      Set ret = c
      Exit For
    End If
  Next
  Set GetCustomLayout = ret
End Function

上記ExecuteMsoメソッドの引数であるコントロールID(PasteSourceFormatting(元の書式を保持)、PasteAsEmbedded(埋め込み)、PasteExcelTableDestinationTableStyle(貼り付け先のスタイルを使用)等)は下記リンク先からダウンロードできる、コントロールIDリストに記載されているので、必要に応じて参照してください。

[Officeアドイン]ローカルの画像ファイルをWord文書に挿入する。前のページ

プリキュアオールスターズの映画を観てきました。次のページ

関連記事

  1. Office関連

    Excelを使わずにCSVからExcelファイルに変換するPowerShellコード

    CSVファイルからExcelファイルに変換する処理を自動化したい、Ex…

  2. Office関連

    既存の機能の代わりにマクロを実行する方法をまとめてみました。

    「既存の機能の代わりにマクロを実行する」の関連になりますが、Offic…

  3. Office アドイン

    Office 365でVisio JavaScript APIsを試してみました。

    昨年末にVisio Onlineの機能をJavaScriptで拡張する…

  4. Office関連

    ヘッドレス ChromeとSeleniumBasicでWebページ全体のスクリーンショットを撮る方法…

    先日、ヘッドレス ChromeでWebページ全体のスクリーンショットを…

  5. Office関連

    テーブルの罫線色情報を列挙するPowerPointマクロ

    テーブルが多いプレゼンテーションファイルの、各テーブルの線の色の情報を…

コメント

  • コメント (0)

  • トラックバックは利用できません。

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

Translate

Chinese (Simplified)Chinese (Traditional)EnglishFrenchGermanJapaneseKoreanRussianSpanish

最近の記事

アーカイブ

PAGE TOP