各スライドに配置されたオートシェイプからテキストを抜き出す処理を考えてみました。
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***の内容を変更する必要があります。
この記事へのコメントはありません。