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関連

    [Excel Services ECMAScript]アクティブなシート名を取得する。

    埋め込んだExcelワークブックのアクティブなシート名を取得するコード…

  2. Excel

    Microsoft Translator APIで文字列を翻訳するVBAマクロ

    以前書いた記事で、Google翻訳を使って文字列を翻訳するマクロを紹介…

  3. Office関連

    「EXCEL VBA 業務自動化 仕事の効率を劇的に上げるノウハウ」レビュー

    ※ 下記レビューはあくまでも個人的な感想です。2015年4…

  4. Office関連

    指定したフォルダ内にあるExcelファイルを一つにまとめるVBAマクロ

    複数あるファイルを一つにまとめるにはどうすれば良いか?という質問をいた…

  5. Office関連

    Office 2019 Commercial Preview版のインストール方法

    「Microsoft、「Office 2019 Commercial …

  6. Office関連

    ビジネスITアカデミーの無料VBAセミナーに行ってきました。

    Excel MVPの伊藤さんやWord MVPの新田さんのブログ記事で…

コメント

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP