我想展示我在powerpoint演示文稿中的所有形状类型。我试过这些代码：
Private Sub CommandButton1_Click()
Dim it As String
Dim i As Integer
Dim Ctr As Integer
'''''''''''''''''
'Read-only Long
'''''''''''''''''
For Each slid In ActivePresentation.Slides
For Each s In slid.Shapes
'No need to select the object in order to use it
With s
'But it is easier to watch when the object is selected
'This next line is for demonstration purposes only.
'It is not necessary
s.Select
Select Case .Type
'Type 1
Case msoAutoShape
it = "an AutoShape. Type : " & .Type
'Type 2
Case msoCallout
it = "a Callout. Type : " & .Type
'Type 3
Case msoChart
it = "a Chart. Type : " & .Type
'Type 4
Case msoComment
it = "a Comment. Type : " & .Type
'Type 5
Case msoFreeform
it = "a Freeform. Type : " & .Type
'Type 6
Case msoGroup
it = "a Group. Type : " & .Type
' If it's a group them iterate thru
' the items and list them
it = it & vbCrLf & "Comprised of..."
For Ctr = 1 To .GroupItems.Count
it = it & vbCrLf & _
.GroupItems(Ctr).Name & _
". Type:" & .GroupItems(Ctr).Type
Next Ctr
'Type 7
Case msoEmbeddedOLEObject
it = "an Embedded OLE Object. Type : " & .Type
'Type 8
Case msoFormControl
it = "a Form Control. Type : " & .Type
'Type 9
Case msoLine
it = "a Line. Type : " & .Type
'Type 10
Case msoLinkedOLEObject
it = "a Linked OLE Object. Type : " & .Type
With .LinkFormat
it = it & vbCrLf & "My Source: " & _
.SourceFullName
End With
'Type 11
Case msoLinkedPicture
it = "a Linked Picture. Type : " & .Type
With .LinkFormat
it = it & vbCrLf & "My Source: " & _
.SourceFullName
End With
'Type 12
Case msoOLEControlObject
it = "an OLE Control Object. Type : " & .Type
'Type 13
Case msoPicture
it = "a embedded picture. Type : " & .Type
'Type 14
Case msoPlaceholder
it = "a text placeholder (title or regular text--" & _
"not a standard textbox) object." & _
"Type : " & .Type
'Type 15
Case msoTextEffect
it = "a WordArt (Text Effect). Type : " & .Type
'Type 16
Case msoMedia
it = "a Media object .. sound, etc. Type : " & .Type
With .LinkFormat
it = it & vbCrLf & " My Source: " & _
.SourceFullName
End With
'Type 17
Case msoTextBox
it = "a Text Box."
'Type 18 = msoScriptAnchor, not defined in PPT pre-2000 so we use the numeric value
'Case msoScriptAnchor
Case 18
it = " a ScriptAnchor. Type : " & .Type
'Type 19 = msoTable, not defined in PPT pre-2000 so we use the numeric value
'Case msoTable
Case 19
it = " a Table. Type : " & .Type
'Type 19 = msoCanvas, not defined in PPT pre-2000 so we use the numeric value
'Case msoCanvas
Case 20
it = " a Canvas. Type : " & .Type
'Type 21 = msoDiagram, not defined in PPT pre-2000 so we use the numeric value
'Case msoDiagram
Case 22
it = " a Diagram. Type : " & .Type
'Type 22 = msoInk, not defined in PPT pre-2000 so we use the numeric value
'Case msoInk
Case 22
it = " an Ink shape. Type : " & .Type
'Type 23 = msoInkComment, not defined in PPT pre-2000 so we use the numeric value
'Case msoInkComment
Case 23
it = " an InkComment. Type : " & .Type
'Type -2
Case msoShapeTypeMixed
it = "a Mixed object (whatever that might be)." & _
"Type : " & .Type
'Just in case
Case Else
it = "a mystery!? An undocumented object type?" & _
" Haven't found one of these yet!"
End Select
MsgBox ("I'm " & it)
End With
Next
Next
End Sub
我从这个代码中取出了代码并进行了一些修改，但没有人适合我：
Sub Object_Types_on_This_Slide()
'Refers to each object on the current page and returns the Shapes.Type
'Can be very useful when searching through all objects on a page
Dim it As String
Dim i As Integer
Dim Ctr As Integer
'''''''''''''''''
'Read-only Long
'''''''''''''''''
For i = 1 To ActiveWindow.Selection.SlideRange.Shapes.Count
'No need to select the object in order to use it
With ActiveWindow.Selection.SlideRange.Shapes(i)
'But it is easier to watch when the object is selected
'This next line is for demonstration purposes only.
'It is not necessary
ActiveWindow.Selection.SlideRange.Shapes(i).Select
Select Case .Type
'Type 1
Case msoAutoShape
it = "an AutoShape. Type : " & .Type
'Type 2
Case msoCallout
it = "a Callout. Type : " & .Type
'Type 3
Case msoChart
it = "a Chart. Type : " & .Type
'Type 4
Case msoComment
it = "a Comment. Type : " & .Type
'Type 5
Case msoFreeform
it = "a Freeform. Type : " & .Type
'Type 6
Case msoGroup
it = "a Group. Type : " & .Type
' If it's a group them iterate thru
' the items and list them
it = it & vbCrLf & "Comprised of..."
For Ctr = 1 To .GroupItems.Count
it = it & vbCrLf & _
.GroupItems(Ctr).Name & _
". Type:" & .GroupItems(Ctr).Type
Next Ctr
'Type 7
Case msoEmbeddedOLEObject
it = "an Embedded OLE Object. Type : " & .Type
'Type 8
Case msoFormControl
it = "a Form Control. Type : " & .Type
'Type 9
Case msoLine
it = "a Line. Type : " & .Type
'Type 10
Case msoLinkedOLEObject
it = "a Linked OLE Object. Type : " & .Type
With .LinkFormat
it = it & vbCrLf & "My Source: " & _
.SourceFullName
End With
'Type 11
Case msoLinkedPicture
it = "a Linked Picture. Type : " & .Type
With .LinkFormat
it = it & vbCrLf & "My Source: " & _
.SourceFullName
End With
'Type 12
Case msoOLEControlObject
it = "an OLE Control Object. Type : " & .Type
'Type 13
Case msoPicture
it = "a embedded picture. Type : " & .Type
'Type 14
Case msoPlaceholder
it = "a text placeholder (title or regular text--" & _
"not a standard textbox) object." & _
"Type : " & .Type
'Type 15
Case msoTextEffect
it = "a WordArt (Text Effect). Type : " & .Type
'Type 16
Case msoMedia
it = "a Media object .. sound, etc. Type : " & .Type
With .LinkFormat
it = it & vbCrLf & " My Source: " & _
.SourceFullName
End With
'Type 17
Case msoTextBox
it = "a Text Box."
'Type 18 = msoScriptAnchor, not defined in PPT pre-2000 so we use the numeric value
'Case msoScriptAnchor
Case 18
it = " a ScriptAnchor. Type : " & .Type
'Type 19 = msoTable, not defined in PPT pre-2000 so we use the numeric value
'Case msoTable
Case 19
it = " a Table. Type : " & .Type
'Type 19 = msoCanvas, not defined in PPT pre-2000 so we use the numeric value
'Case msoCanvas
Case 20
it = " a Canvas. Type : " & .Type
'Type 21 = msoDiagram, not defined in PPT pre-2000 so we use the numeric value
'Case msoDiagram
Case 22
it = " a Diagram. Type : " & .Type
'Type 22 = msoInk, not defined in PPT pre-2000 so we use the numeric value
'Case msoInk
Case 22
it = " an Ink shape. Type : " & .Type
'Type 23 = msoInkComment, not defined in PPT pre-2000 so we use the numeric value
'Case msoInkComment
Case 23
it = " an InkComment. Type : " & .Type
'Type -2
Case msoShapeTypeMixed
it = "a Mixed object (whatever that might be)." & _
"Type : " & .Type
'Just in case
Case Else
it = "a mystery!? An undocumented object type?" & _
" Haven't found one of these yet!"
End Select
MsgBox ("I'm " & it)
End With
Next i
End Sub
为什么它不起作用？我做错了吗？
答案 0 :(得分：2)
我在幻灯片显示运行时找到了一种方法。这是代码：
Private Sub CommandButton2_Click()
Dim sNum As Integer
Dim stri As String
Dim i, j As Integer
Dim right As Boolean
Dim value As MsoShapeType
Dim it As String
right = True
k = 0
j = 0
it = "Cannot convert the file due to the following problems:" & vbNewLine & vbNewLine
'ActivePresentation.Slides(1).Hyperlinks(1).SubAddress
For Each sld In ActivePresentation.Slides
For i = 1 To sld.Shapes.Count
'Type 1
If sld.Shapes(i).Type = msoAutoShape Then
it = it & "AutoShape" & vbNewLine
right = False
End If
'Type 2
If sld.Shapes(i).Type = msoCallout Then
it = it & "Callout." & vbNewLine
right = False
End If
'Type 3
If sld.Shapes(i).Type = msoChart Then
it = it + "Chart." & vbNewLine
right = False
End If
'Type 4
If sld.Shapes(i).Type = msoComment Then
'it = it + "a Comment. Type : " & .Type
End If
'Type 5
If sld.Shapes(i).Type = msoFreeform Then
it = it + "Freeform." & vbNewLine
right = False
End If
'Type 6
If sld.Shapes(i).Type = msoGroup Then
it = it + "Group." & vbNewLine
' If it's a group them iterate thru
' the items and list them
it = it & vbCrLf & "Comprised of..."
'For Ctr = 1 To .GroupItems.Count
' it = it & vbCrLf & _
' .GroupItems(Ctr).Name & _
' ". Type:" & .GroupItems(Ctr).Type & vbNewLine
'Next Ctr
right = False
End If
'Type 7
If sld.Shapes(i).Type = msoEmbeddedOLEObject Then
it = it + "Embedded OLE Object" & vbNewLine
right = False
End If
'Type 8
If sld.Shapes(i).Type = msoFormControl Then
it = it + "Form Control" & vbNewLine
right = False
End If
'Type 9
If sld.Shapes(i).Type = msoLine Then
'it = it + "a Line. Type : " & .Type
End If
'Type 10
If sld.Shapes(i).Type = msoLinkedOLEObject Then
'it = it + "a Linked OLE Object. Type : " & .Type
'With .LinkFormat
' it = it & vbCrLf & "My Source: " & _
' .SourceFullName
'End With
End If
'Type 11
If sld.Shapes(i).Type = msoLinkedPicture Then
it = it + "Linked Picture" & vbNewLine
'With .LinkFormat
' it = it + it & vbCrLf & "My Source: " & _
' .SourceFullName
'End With
right = False
End If
'Type 12
If sld.Shapes(i).Type = msoOLEControlObject Then
it = it & "OLE Control Object" & vbNewLine
right = False
End If
'Type 13
If sld.Shapes(i).Type = msoPicture Then
it = it & "Embedded picture" & vbNewLine
right = False
End If
'Type 14
If sld.Shapes(i).Type = msoPlaceholder Then
'it = it & "text placeholder (title or regular text--" & _
' "not a standard textbox) object." & _
' "Type : " & .Type
' right = False
End If
'Type 15
If sld.Shapes(i).Type = msoTextEffect Then
'it = it + "WordArt (Text Effect). Type : " & .Type
End If
'Type 16
If sld.Shapes(i).Type = msoMedia Then
it = it & "Media object .. sound, etc" & vbNewLine
'With .LinkFormat
' it = it & vbCrLf & " My Source: " & _
' .SourceFullName
'End With
right = False
End If
'Type 17
If sld.Shapes(i).Type = msoTextBox Then
'it = "a Text Box."
End If
'Type 18 = msoScriptAnchor, not defined in PPT pre-2000 so we use the numeric value
'Case msoScriptAnchor
If sld.Shapes(i).Type = 18 Then
it = it & "ScriptAnchor" & vbNewLine
right = False
End If
'Type 19 = msoTable, not defined in PPT pre-2000 so we use the numeric value
'Case msoTable
If sld.Shapes(i).Type = 19 Then
'it = " a Table. Type : " & .Type
End If
'Type 19 = msoCanvas, not defined in PPT pre-2000 so we use the numeric value
'Case msoCanvas
If sld.Shapes(i).Type = 20 Then
it = "Canvas" & vbNewLine
right = False
End If
'Type 21 = msoDiagram, not defined in PPT pre-2000 so we use the numeric value
'Case msoDiagram
If sld.Shapes(i).Type = 21 Then
it = it + "Diagram" & vbNewLine
right = False
End If
'Type 22 = msoInk, not defined in PPT pre-2000 so we use the numeric value
'Case msoInk
If sld.Shapes(i).Type = 22 Then
it = it + "Ink shape" & vbNewLine
right = False
End If
'Type 23 = msoInkComment, not defined in PPT pre-2000 so we use the numeric value
'Case msoInkComment
If sld.Shapes(i).Type = 23 Then
it = it + "InkComment" & vbNewLine
right = False
End If
'Type -2
If sld.Shapes(i).Type = msoShapeTypeMixed Then
it = "Mixed object (whatever that might be)" & nvNewLine
right = False
End If
'Just in case
'Case Else
' it = "mystery!? An undocumented object type?" & _
' " Haven't found one of these yet!" & nvNewLine
'
' right = False
'End Select
'MsgBox ("I'm " & it)
'End With
Next i
Next
Dim slidNum As Integer
slidNum = 1
For Each slid In ActivePresentation.Slides
If slid.TimeLine.MainSequence.Count >= 1 Then
it = it & "Number of animations in slide " & slidNum & ": " & Str(slid.TimeLine.MainSequence.Count) & vbNewLine
right = False
End If
slidNum = slidNum + 1
Next
If right = True Then
For Each slid In ActivePresentation.Slides
For i = 1 To slid.Hyperlinks.Count
If slid.Hyperlinks(i).SubAddress = "" Then
MsgBox "Address: " + slid.Hyperlinks(i).Address
'MsgBox "Here there is a hyperlink: " + slid.Hyperlinks(i).Type
Else
MsgBox "Subaddress: " + slid.Hyperlinks(i).SubAddress
stri = Mid(slid.Hyperlinks(i).SubAddress, 5, 1)
sNum = CInt(stri) - 1
MsgBox "The link must go to Story Number: " + Str(sNum)
End If
Next i
Next
ActivePresentation.SaveAs "c:\dink_presentation2", ppSaveAsPNG, msoTrue
Else
MsgBox (it & vbNewLine & "Please fix this errors to before continue")
End If
希望对某人有所帮助。
答案 1 :(得分：1)
如果您希望子程序适用于每个演示幻灯片，而不是需要放回您移除的外部循环。
您需要移除3条线，而您需要放置几条线：
'For i = 1 To ActiveWindow.Selection.SlideRange.Shapes.Count 'remove
'With ActiveWindow.Selection.SlideRange.Shapes(i) 'remove
'ActiveWindow.Selection.SlideRange.Shapes(i).Select 'remove
Dim sld As Slide
For Each sld In ActivePresentation.Slides
sld.Select
For i = 1 To sld.Shapes.Count
With sld.Shapes(i)
.Select
...
...
...
Next i
Next '<-- add this too
希望我没有错过任何东西：）