代码如下:


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