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

















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