Office関連

各スライドに配置されたオートシェイプからテキストを取得するPowerPointマクロ

各スライドに配置されたオートシェイプからテキストを抜き出す処理を考えてみました。

Option Explicit

Public Sub Sample()
  Dim sld As PowerPoint.Slide
  Dim shp As PowerPoint.Shape
  Dim gshps As PowerPoint.GroupShapes
  Dim tmpsld As PowerPoint.Slide
  Dim tmpvt As PowerPoint.PpViewType
  
  If Application.SlideShowWindows.Count > 0& Then Exit Sub
  tmpvt = Application.ActiveWindow.ViewType
  Application.ActiveWindow.ViewType = ppViewNormal
  Set tmpsld = Application.ActivePresentation.Slides.FindBySlideID _
  (Application.ActivePresentation.Windows(1).Selection.SlideRange.SlideID)
  For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
      Set gshps = Nothing
      On Error Resume Next
      Set gshps = shp.GroupItems
      On Error GoTo 0
      If gshps Is Nothing Then
        SortShape shp
      Else
        SortGroupShape gshps
      End If
    Next
  Next
  tmpsld.Select
  Application.ActiveWindow.ViewType = tmpvt
End Sub

Private Sub SortGroupShape(ByVal gshps As PowerPoint.GroupShapes)
'グループ化されたシェイプの振り分け
  Dim shp As PowerPoint.Shape
  Dim subgshps As PowerPoint.GroupShapes
  
  For Each shp In gshps
    Set subgshps = Nothing
    On Error Resume Next
    Set subgshps = shp.GroupItems
    On Error GoTo 0
    If subgshps Is Nothing Then
      SortShape shp
    Else
      SortGroupShape subgshps
    End If
  Next
End Sub

Private Sub SortShape(ByVal shp As PowerPoint.Shape)
'シェイプの振り分け
  Dim n As Office.SmartArtNode
  Dim clm As PowerPoint.Column
  Dim c As PowerPoint.Cell
    
  Select Case shp.Type
    Case msoSmartArt
      For Each n In shp.SmartArt.Nodes
        If n.TextFrame2.HasText = True Then MainProcSmartArtNode n
      Next
    Case msoTable
      For Each clm In shp.Table.Columns
        For Each c In clm.Cells
          If c.Shape.TextFrame.HasText = True Then MainProcShape c.Shape
        Next
      Next
    Case msoChart
      MainProcChart shp
    Case Else
      If shp.TextFrame.HasText = True Then MainProcShape shp
  End Select
End Sub

Private Sub MainProcShape(ByRef shp As PowerPoint.Shape)
  Debug.Print shp.Parent.Name, shp.TextFrame.TextRange.Text
End Sub

Private Sub MainProcSmartArtNode(ByRef nd As Office.SmartArtNode)
  Debug.Print nd.Parent.Name, nd.TextFrame2.TextRange.Text
End Sub

Private Sub MainProcChart(ByRef shp As PowerPoint.Shape)
  Dim r As Object
  
  On Error Resume Next
  shp.Parent.Select: DoEvents: shp.Select
  Application.CommandBars.ExecuteMso "ChartShowData"
  If Err.Number = 0 Then
    For Each r In shp.Chart.ChartData.Workbook.ActiveSheet.UsedRange
      Debug.Print shp.Parent.Name, r.Text
    Next
    shp.Chart.ChartData.Workbook.Close
  Else
    Debug.Print shp.Name & "のセル内容の取得に失敗しました。"
  End If
  On Error GoTo 0
End Sub

オートシェイプの種類によってテキストの抜き出し方が異なるため、とりあえず、スマートアートやテーブル、グラフ、グループ化されたオブジェクトも考慮してみました。

上記コードではDebug.Printで単にイミディエイトウィンドウに文字列を出力しているだけなので、取得した文字列を外部に保存する場合はMainProc***の内容を変更する必要があります。

Acrobatを利用してPDFファイルのページ数を取得するVBAマクロ前のページ

スライド内容を自動的に機械翻訳するPowerPointマクロ次のページ

関連記事

  1. Office関連

    ClosedXMLやEPPlusでExcelファイルを読み書きしてみた。

    今回の記事の発端は下記のQiita投稿。・Excelファイ…

  2. Office アドイン

    [Office用アプリ]カレンダーから日付を入力するコンテンツアプリ。

    ※ この情報はOffice 2013 カスタマー プレビュー版を元にし…

  3. Office関連

    Data Explorerのフォーラム&ブログ

    前回の記事で紹介した「Data Explorer」ですが、すでにフォー…

  4. Office関連

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

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

  5. Office関連

    Excelで地理データや株価情報を取得する方法

    下記記事にある、今年3月に追加された「データの種類」機能を使って、Ex…

  6. Office関連

    【2018年7月版】ソースコードを番号行付きのテーブルに変換するWordマクロ

    6年以上前、Wordに貼り付けたソースコードを番号付きのテーブルに変換…

コメント

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

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP