PPT-VBA-ShapeRange

ning84 · 发表于 2022-9-26 13:13

Option Explicit
Sub ll()
Dim Sld As Slide, ShpRng As ShapeRange, ii
Set Sld = Application.ActivePresentation.Slides(3)
Debug.Print Sld.Name, Sld.Shapes.Count
'Set ShpRng = Sld.Shapes.Item.Name
With Sld
For ii = 1 To .Shapes.Count
.Shapes(ii).Name = "a" & ii 'Sld.Name & "_" & ii
Debug.Print .Shapes(ii).Name
Next ii
Set ShpRng = .Shapes.Range(Array("a1", "a2", "a3"))
End With
Debug.Print ShpRng.Count
For ii = 1 To ShpRng.Count
Debug.Print ShpRng.Item(ii).Name
Next ii
ShpRng.Select
Stop
End Sub

复制代码

天道酬勤y · 发表于 2022-9-26 21:35

啥意思.....

ning84 · 发表于 2022-9-27 03:06

Dim ShpRng As SlideRange-------------------出错
Dim ShpRng As ShapeRange-----------------没出错
证明SlideRange与ShapeRange是有区别的。

Sub ll()
Dim Sld As Slide
'Dim ShpRng As SlideRange
Dim ShpRng As ShapeRange
Dim Arr, ii
Set Sld = Application.ActivePresentation.Slides(1)
Debug.Print Sld.Name, Sld.Shapes.Count
'Set ShpRng = Sld.Shapes.Item.Name
With Sld
'Arr = Array("a1", "a2", "a3")
ReDim Arr(.Shapes.Count - 1)
For ii = 1 To .Shapes.Count
.Shapes(ii).Name = "a" & ii 'Sld.Name & "_" & ii
Arr(ii - 1) = .Shapes(ii).Name
Debug.Print .Shapes(ii).Name, .Shapes(ii).Type
Next ii
Set ShpRng = .Shapes.Range(Arr)
End With
Debug.Print ShpRng.Count
For ii = 1 To ShpRng.Count
Debug.Print Sld.Name, ShpRng.Item(ii).Name,
Debug.Print ShpRng.Item(ii).Type
Next ii
ShpRng.Select
Stop
End Sub

复制代码

ning84 · 发表于 2022-9-27 03:53

标题 1       14          msoPicture
副标题 2       14          msoPicture
直接连接符 6 9          msoLine

Sub ll()
Dim Sld As Slide
'Dim ShpRng As SlideRange
Dim ShpRng As ShapeRange
Dim Arr, ii
Set Sld = Application.ActivePresentation.Slides(1)
Debug.Print Sld.Name, Sld.Shapes.Count
'Set ShpRng = Sld.Shapes.Item.Name
With Sld
'Arr = Array("a1", "a2", "a3")
ReDim Arr(.Shapes.Count - 1)
For ii = 1 To .Shapes.Count
.Shapes(ii).Name = "a" & ii 'Sld.Name & "_" & ii
Arr(ii - 1) = .Shapes(ii).Name
Debug.Print .Shapes(ii).Name, .Shapes(ii).Type
Next ii
Set ShpRng = .Shapes.Range(Arr)
End With
Debug.Print ShpRng.Count
For ii = 1 To ShpRng.Count
Debug.Print Sld.Name, ShpRng.Item(ii).Name,
Debug.Print ShpRng.Item(ii).Type
Next ii
ShpRng.Select
Stop
End Sub
Sub ll1()
Dim ShapeTypeArr(21)
ShapeTypeArr(0) = "msoAutoShape"
ShapeTypeArr(1) = "msoCallout"
ShapeTypeArr(2) = "msoCanvas"
ShapeTypeArr(3) = "msoChart"
ShapeTypeArr(4) = "msoComment"
ShapeTypeArr(5) = "msoDiagram"
ShapeTypeArr(6) = "msoEmbeddedOLEObject"
ShapeTypeArr(7) = "msoFormControl"
ShapeTypeArr(8) = "msoFreeform"
ShapeTypeArr(9) = "msoGroup"
ShapeTypeArr(10) = "msoLine"
ShapeTypeArr(11) = "msoLinkedOLEObject"
ShapeTypeArr(12) = "msoLinkedPicture"
ShapeTypeArr(13) = "msoMedia"
ShapeTypeArr(14) = "msoOLEControlObject"
ShapeTypeArr(15) = "msoPicture"
ShapeTypeArr(16) = "msoPlaceholder"
ShapeTypeArr(17) = "msoScriptAnchor"
ShapeTypeArr(18) = "msoShapeTypeMixed"
ShapeTypeArr(19) = "msoTable"
ShapeTypeArr(20) = "msoTextBox"
ShapeTypeArr(21) = "msoTextEffect"
Dim Sld As Slide
Dim ShpRng As ShapeRange
Set Sld = Application.ActivePresentation.Slides(2)
With Sld
For ii = 1 To .Shapes.Count
Debug.Print .Shapes(ii).Name, .Shapes(ii).Type, ShapeTypeArr(.Shapes(ii).Type + 1)
Next ii
End With
End Sub

复制代码

ning84 · 发表于 2023-11-27 12:08

经常复习

Sub t()
Dim Pres As Presentation
Dim Sld As Slide, Shp As Shape, ShpArr(2) As Shape
Set Pres = Application.ActivePresentation
Set Sld = Pres.Slides(3)
For ii = 2 To Sld.Shapes.Count
Set ShpArr(ii - 2) = Sld.Shapes(ii)
Debug.Print ShpArr(ii - 2).Name
Next ii
For ii = 4 To Pres.Slides.Count
Set Sld = Pres.Slides(ii)
Sld.Select
For ii1 = 0 To 2
ShpArr(ii1).Copy
Sld.Shapes.Paste
Next ii1
Next ii
End Sub

复制代码

ning84 · 发表于 2023-11-30 09:59

测试Shp.Type = msoLine Or Shp.Type = msoPicture Or Shp.Type = msoAutoShape的应用。

Sub t2()
Dim Pres As Presentation
Dim Sld As Slide, Shp As Shape, ShpArr(2) As Shape
Set Pres = Application.ActivePresentation
For ii = 3 To Pres.Slides.Count
Set Sld = Pres.Slides(ii)
Sld.Select
Sld.NotesPage.Shapes(3).TextFrame.TextRange.Text = "A" & ii
For Each Shp In Sld.Shapes
''
Debug.Print Shp.Name, Shp.Type
If Shp.Type = msoLine Or Shp.Type = msoPicture Or Shp.Type = msoAutoShape Then
Shp.Select
Shp.Delete
End If
Next Shp
'
Next ii
End Sub

复制代码

ning84 · 发表于 2023-11-30 11:01

SourceFullName的应用

LinkFormat.SourceFullName 属性 (PowerPoint) | Microsoft Learn  https://learn.microsoft.com/zh-c ... rmat.sourcefullname

With ActivePresentation.Slides(1).Shapes(1)

If .Type = msoLinkedOLEObject Then

      With .LinkFormat

         .SourceFullName = "c:\my documents\wordtest.doc"

         .AutoUpdate = ppUpdateOptionAutomatic

      End With

End If

End With
**************************************

Sub t3()
Dim Pres As Presentation
Dim Sld As Slide, Shp As Shape, ShpArr(2) As Shape
Set Pres = Application.ActivePresentation
Dim AddressName
PathName = "D:\JPGManage\SpecialSubject\GongbeiCommunity\ChangshengCommunity\IMG_20231121_101925520.jpg"
For ii = 3 To Pres.Slides.Count
Set Sld = Pres.Slides(ii)
Sld.Select
Sld.NotesPage.Shapes(3).TextFrame.TextRange.Text = "A" & ii
For Each Shp In Sld.Shapes
''
Debug.Print Shp.Name, Shp.Type, Shp.Type = msoLinkedPicture
''
With Shp
If Shp.Type = msoLinkedPicture Then
.Select
AddressName = Shp.LinkFormat.SourceFullName
.LinkFormat.SourceFullName = PathName
.LinkFormat.AutoUpdate = ppUpdateOptionAutomatic
.ActionSettings(ppMouseClick).Hyperlink.Address = AddressName
End If
End With
Next Shp
'
Next ii
End Sub

复制代码

ning84 · 发表于 2023-12-1 19:21

继续整理

Sub t()
Dim Pres As Presentation
Dim Sld As Slide, Shp As Shape, ShpArr(2) As Shape
Set Pres = Application.ActivePresentation
Set Sld = Pres.Slides(3)
For ii = 2 To Sld.Shapes.Count
Set ShpArr(ii - 2) = Sld.Shapes(ii)
Debug.Print ShpArr(ii - 2).Name
Next ii
For ii = 4 To Pres.Slides.Count
Set Sld = Pres.Slides(ii)
Sld.Select
For ii1 = 0 To 2
ShpArr(ii1).Copy
Sld.Shapes.Paste
Next ii1
Next ii
End Sub
Sub t1()
Dim Pres As Presentation
Dim Sld As Slide, Shp As Shape, ShpArr(2) As Shape
Set Pres = Application.ActivePresentation
For ii = 31 To Pres.Slides.Count
Set Sld = Pres.Slides(ii)
Debug.Print Sld.NotesPage.Shapes(3).TextFrame.TextRange.Text
Stop
With Sld.NotesPage.Shapes
Debug.Print .Placeholders(2).TextFrame.TextRange.Text
Debug.Print .Placeholders(3).TextFrame.TextRange.Text
End With
'
Next ii
End Sub
Sub t2()
Dim Pres As Presentation
Dim Sld As Slide, Shp As Shape, ShpArr(2) As Shape
Dim PicName
Dim oShp As Shape
Set Pres = Application.ActivePresentation
PicName = "D:\JPGManage\SpecialSubject\GongbeiCommunity\ChangshengCommunity\ChangshengCommunity.jpg"
For ii = 3 To Pres.Slides.Count
Set Sld = Pres.Slides(ii)
Sld.Select
'Sld.NotesPage.Shapes(3).TextFrame.TextRange.Text = "A" & ii
For Each Shp In Sld.Shapes
'Debug.Print Shp.Name, Shp.Type
If Shp.Type = msoLine Then
'Shp.Delete
End If
If Shp.Type = msoPicture Then
Shp.Select msoTrue
With Shp.ActionSettings(ppMouseClick)
'.Action = ppActionHyperlink
'.Hyperlink.Address = PicName
End With
If Shp.Name = "图片 2" Then
Set oShp = Sld.Shapes.AddPicture(PicName, msoCTrue, msoCTrue, Shp.Left, Shp.Top, Shp.Width, Shp.Height)
With oShp.ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.Address = PicName
End With
Shp.Select
Shp.Delete
End If
End If
''
If Shp.Name = "ChangshengCommunity.jpg" Then
Stop
Shp.LinkFormat.SourceFullName = PicName
Shp.LinkFormat.AutoUpdate = ppUpdateOptionAutomatic
Shp.ActionSettings(ppMouseClick).Hyperlink.Address = PicName
Debug.Print Shp.Name, Shp.Type
End If
Next Shp
'
Next ii
End Sub
Sub t3()
Dim Pres As Presentation
Dim Sld As Slide, Shp As Shape, ShpArr(2) As Shape
Set Pres = Application.ActivePresentation
Dim SourceFile As LinkFormat
PathName = "D:\JPGManage\SpecialSubject\GongbeiCommunity\ChangshengCommunity\IMG_20231121_101925520.jpg"
For ii = 22 To Pres.Slides.Count
Set Sld = Pres.Slides(ii)
Sld.Select
Sld.NotesPage.Shapes(3).TextFrame.TextRange.Text = "A" & ii
For Each Shp In Sld.Shapes
''
Debug.Print Shp.Name, Shp.Type, Shp.Type = msoLinkedPicture
Set SourceFile = Shp.LinkFormat
Debug.Print SourceFile.SourceFullName
''
If Shp.Type = msoLinkedPicture Then
Shp.Select
Shp.LinkFormat.SourceFullName = PathName
Shp.LinkFormat.AutoUpdate = ppUpdateOptionAutomatic
Debug.Print Shp.Name
Stop
Stop
Shp.ActionSettings(ppMouseOver).Hyperlink.Address = AddressName
End If
Next Shp
'
Next ii
End Sub
''
Sub t44()
Dim Pres As Presentation
Set Pres = Application.ActivePresentation
Dim Sld As Slide, Shp As Shape
For ii = 5 To Pres.Slides.Count - 1
Set Sld = Pres.Slides(ii)
Sld.Select
Set Shp = Sld.Shapes(3)
Shp.Select
Shp.Delete
Next ii
End Sub
Sub t4()
Dim Pres As Presentation
Set Pres = Application.ActivePresentation
Dim Sld As Slide, Shp As Shape
For ii = 4 To Pres.Slides.Count
Set Sld = Pres.Slides(ii)
Sld.Select
For Each Shp In Sld.Shapes
Debug.Print Sld.Name, Shp.Name, Shp.Type
If Shp.Type = 1 Then
Shp.Select msoTrue
Shp.Delete
End If
Next Shp
Next ii
End Sub
Sub t5()
Dim Pres As Presentation
Set Pres = Application.ActivePresentation
Dim Sld As Slide, Shp As Shape, oShp As Shape
Set Sld = Pres.Slides(3)
Sld.Select
Set Shp = Sld.Shapes(3)
Debug.Print Shp.Name
'Shp.Select msoTrue
'Shp.Copy
Shp.Name = "MarkingLine"
'Shp.Copy
For ii = 4 To Pres.Slides.Count
'Shp.Select msoTrue
Shp.Copy
Set Sld = Pres.Slides(ii)
Sld.Select
Sld.Shapes.Paste
Set oShp = Sld.Shapes(Sld.Shapes.Count)
Debug.Print oShp.Name
Next ii
End Sub
Sub t6()
Dim Fso As FileSystemObject, oFile As File
Set Fso = New FileSystemObject
Dim Pres As Presentation
Set Pres = Application.ActivePresentation
Dim Sld As Slide, Shp As Shape, oShp As Shape
Dim Str
Set Sld = Pres.Slides(3)
Sld.Select
For ii = 3 To Pres.Slides.Count
Set Sld = Pres.Slides(ii)
Sld.Select
Set Shp = Sld.Shapes(1)
Str = Shp.LinkFormat.SourceFullName
Set oFile = Fso.GetFile(Str)
Debug.Print oFile.DateLastModified
Set Shp = Sld.Shapes("MarkingLine")
Str = Format(oFile.DateLastModified, "yyyy年mm月dd日 hh:mm:ss[$-804]aaaa") & vbCr
Select Case ii
Case 3 To 15
Str = Str & "拍摄于粤华路"
Case 3 To 15
Str = Str & "拍摄于前河路"
Case 16 To 40
Str = Str & "拍摄于昌盛路"
Case 41 To 65
Str = Str & "拍摄于港昌路"
End Select
With Shp.TextFrame2
.TextRange.Text = Str
.TextRange.Font.Size = 21
End With
Next ii
End Sub

复制代码

ning84 · 发表于 2023-12-5 14:15

学习笔记

Excel 2007 开发人员参考 > 2007 Microsoft Office System 对象库参考 > 2007 Microsoft Office system 的对象模型参考 > 枚举

MsoShapeStyleIndex 枚举
指示线条样式和形状样式。
名称值描述
msoLineStyle1 10001 线条样式 1
msoLineStyle10 10010 线条样式 10
msoLineStyle11 10011 线条样式 11
msoLineStyle12 10012 线条样式 12
msoLineStyle13 10013 线条样式 13
msoLineStyle14 10014 线条样式 14
msoLineStyle15 10015 线条样式 15
msoLineStyle16 10016 线条样式 16
msoLineStyle17 10017 线条样式 17
msoLineStyle18 10018 线条样式 18
msoLineStyle19 10019 线条样式 19
msoLineStyle2 10002 线条样式 2
msoLineStyle20 10020 线条样式 20
msoLineStyle3 10003 线条样式 3
msoLineStyle4 10004 线条样式 4
msoLineStyle5 10005 线条样式 5
msoLineStyle6 10006 线条样式 6
msoLineStyle7 10007 线条样式 7
msoLineStyle8 10008 线条样式 8
msoLineStyle9 10009 线条样式 9
msoShapeStyle1 1 阴影样式 1
msoShapeStyle10 10 阴影样式 10
msoShapeStyle11 11 阴影样式 11
msoShapeStyle12 12 阴影样式 12
msoShapeStyle13 13 阴影样式 13
msoShapeStyle14 14 阴影样式 14
msoShapeStyle15 15 阴影样式 15
msoShapeStyle16 16 阴影样式 16
msoShapeStyle17 17 阴影样式 17
msoShapeStyle18 18 阴影样式 18
msoShapeStyle19 19 阴影样式 19
msoShapeStyle2 2 阴影样式 2
msoShapeStyle20 20 阴影样式 20
msoShapeStyle3 3 阴影样式 3
msoShapeStyle4 4 阴影样式 4
msoShapeStyle5 5 阴影样式 5
msoShapeStyle6 6 阴影样式 6
msoShapeStyle7 7 阴影样式 7
msoShapeStyle8 8 阴影样式 8
msoShapeStyle9 9 阴影样式 9
msoShapeStyleMixed -2 混和的阴影样式。
msoShapeStyleNone 0 无阴影样式。

Sub a()
Dim Pres As Presentation
      Set Pres = Application.ActivePresentation

Dim Shp As Shape
      Set Shp = Pres.Slides(1).Shapes(3)
      Debug.Print Shp.ShapeStyle
End Sub

ning84 · 发表于 2023-12-5 14:57

学习ShapeRange

Sub a()
Dim Pres As Presentation
Set Pres = Application.ActivePresentation
Dim Sld As Slide
Dim Shp As Shape
Dim ShpRng As ShapeRange
Set Sld = Pres.Slides(1)
Set Shp = Sld.Shapes(3)
Debug.Print Shp.ShapeStyle
Stop
Set ShpRng = Sld.Shapes.Range(Array(3))
Debug.Print ShpRng.Name
With ShpRng
Debug.Print .Name, .Nodes.Count
Debug.Print .Line.Style
Stop
Stop
Stop
End With
Stop
Stop
Stop
End Sub

复制代码

		自动登录	找回密码
密码			免费注册