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***の内容を変更する必要があります。

関連記事

  1. Office関連

    フォルダ(サブフォルダ含む)内の特定の拡張子のファイルに処理を行うVBAマクロ

    「Wordマクロ サブフォルダ ファイル処理」といったキーワードでのア…

  2. Office関連

    OneNote + Google Apps Scriptで定期的にWebサイトのキャプチャーを撮る方…

    「“OneNote”がアップデート、URLをメールで送るだけでスクリー…

  3. Office関連

    Excelのアイデア機能でグラフやピボットグラフを一発作成

    Insider版のExcelに「アイデア」機能が追加されました。…

  4. Office関連

    Officeの新製品発売記念イベントに参加してきました。

    今月16日に開催された、Officeの新しい製品の発売記念イベント「平…

  5. Windows 10

    SeleniumBasic(Selenium VBA)がMicrosoft Edgeに対応しました。…

    言わずと知れたWebブラウザーの自動制御ツール「Selenium」のV…

コメント

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

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP