复制代码 代码如下:

Private Sub CommandButton1_Click()

Me.Enabled = False

getTitles

Me.Enabled = True

End Sub

Sub getTitles()

On Error Resume Next

Dim oPres As Presentation

Set oPres = Application.ActivePresentation

Dim oSlide As Slide

Dim oShape As Shape

Dim tr As TextRange

Dim sText As String

Dim i As Long, j As Long

'循环每页幻灯

For i = 1 To oPres.Slides.Count

Set oSlide = oPres.Slides.Item(i)

'获取图形对象

For j = 1 To oSlide.Shapes.Count

Set oShape = oSlide.Shapes.Item(j)

'如果有文字

If oShape.TextFrame.HasText = msoTrue Then

Set tr = oShape.TextFrame.TextRange

sText = tr.Text

'如果符合格式: 根据情况设定, 此处前三位构成为x.y

If IsNumeric(Left(sText, 3)) Then

'MsgBox sText

TextBox1.SelStart = 65535

TextBox1.SelText = sText & vbCrLf

End If

Set tr = Nothing

End If

Set oShape = Nothing

Next

Set oSlide = Nothing

Next

Set oPres = Nothing

End Sub