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

    段落内改行を一括置換するOutlookマクロ

    「段落内改行 置換 Outlook マクロ」といったキーワードでのアク…

  2. Office関連

    格子状にガイドを追加するPowerPointマクロ

    前回の記事で、PowerPoint 2013で追加されたGuide、G…

  3. Office関連

    [Office 2013]サインインを無効にする。(2)

    前回の記事では「SignInOptions」の値を変更してサインインを…

  4. Office関連

    指定したスライドにユーザー設定レイアウトを適用するPowerPointマクロ

    PowerPointにはオリジナルのレイアウト(ユーザー設定レイアウト…

  5. Excel

    PDFのしおり情報を出力するVBAマクロ

    Acrobatフォーラムの下記スレッドで当ブログへのリンクが貼られてい…

コメント

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP