测试GrpChart.Application.DataSheet.Font没成功。

ning84 · 发表于 2023-1-31 10:05

本帖最后由 ning84 于 2023-1-31 19:42 编辑

关键语句 GrpChart.Application.DataSheet.Font.Size，测试多次都没变化。

Sub del11()
Dim Pres As Presentation
Dim Sld As Slide
Dim objChart As ChartObject
Dim oChart As Chart
Dim GrpChart As Graph.Chart
Dim GrpSht As Graph.DataSheet
Dim Shp As Shape
Dim ShpRng As ShapeRange
Set Pres = Application.ActivePresentation
Set Sld = Pres.Slides(1)
Set GrpChart = Sld.Shapes(1).OLEFormat.Object
GrpChart.Activate
Set GrpSht = GrpChart.Application.DataSheet
GrpChart.HasDataTable = True
With GrpChart.Application.DataSheet
.Activate
.Font.Size = 50
.Font.ColorIndex = 5
End With
''
For ii = 1 To 1
'Debug.Print GrpChart.SeriesCollection(ii).Name
With GrpChart.SeriesCollection(ii)
With .DataLabels
.Font.Size = 15
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
.ReadingOrder = xlLTR
.Position = xlLabelPositionInsideBase
.Orientation = xlHorizonta
End With
End With
Next ii
'Set Shp = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 100, 20)
'Shp.TextFrame.TextRange.Text = "ffffffffffffffaaaaaa"
'Stop
End Sub

复制代码

Sub del()
Dim Pres As Presentation
Dim Sld As Slide
Dim Shp As Shape
Dim GrpChart As Graph.Chart
Set Pres = Application.ActivePresentation
Set GrpChart = Pres.Slides(1).Shapes(1).OLEFormat.Object
With GrpChart
For ii = 1 To 3
.SeriesCollection(ii).ApplyDataLabels AutoText:=True, LegendKey:= _
False, ShowSeriesName:=False, ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=False, ShowBubbleSize:=False
With .SeriesCollection(ii)
Debug.Print .ChartType
With .Border
.Weight = xlThick
.LineStyle = xlAutomatic
End With
End With
Next ii
End With
End Sub

复制代码

vbee · 发表于 2023-1-31 16:00

PPT会的人比较少

ning84 · 发表于 2023-1-31 21:56

没任何办法，只能宏录制一点一点测试。

''
Sub del11()
Dim Pres As Presentation
Dim Sld As Slide
Dim objChart As ChartObject
Dim oChart As Chart
Dim GrpChart As Graph.Chart
Dim GrpSht As Graph.DataSheet
Dim Shp As Shape
Dim ShpRng As ShapeRange
Set Pres = Application.ActivePresentation
Set Sld = Pres.Slides(1)
Set GrpChart = Sld.Shapes(1).OLEFormat.Object
GrpChart.Activate
Set Shp = Sld.Shapes(1)
Set GrpSht = GrpChart.Application.DataSheet
GrpChart.HasDataTable = True
''
For ii = 1 To 1
'Debug.Print GrpChart.SeriesCollection(ii).Name
With Shp
.Width = 500
.Height = 350
.Top = 100
.Left = 10
End With
With GrpChart.SeriesCollection(ii)
GrpChart.ChartArea.Font.Size = 10
With .DataLabels.Font
.Name = "黑体"
.FontStyle = "黑体"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = True
.Underline = xlUnderlineStyleNone
.ColorIndex = 1 'xlAutomatic
.Background = xlOpaque
End With
With .DataLabels
.Shadow = True
.Interior.ColorIndex = 28
.Interior.PatternColorIndex = 1
.Interior.Pattern = xlSolid
.Border.ColorIndex = xlThin
.Border.Weight = xlMedium
.Border.LineStyle = xlContinuous
.Border.ColorIndex = 1
.Border.Weight = xlMedium
.Border.LineStyle = xlContinuous
End With
End With
Next ii
End Sub

复制代码

lss001 · 发表于 2023-2-1 08:07

ning84 发表于 2023-1-31 21:56
没任何办法，只能宏录制一点一点测试。

https://learn.microsoft.com/zh-cn/office/vba/api/powerpoint.shapes

ning84 · 发表于 2023-2-1 09:48

本帖最后由 ning84 于 2023-2-1 12:00 编辑

lss001 发表于 2023-2-1 08:07
https://learn.microsoft.com/zh-cn/office/vba/api/powerpoint.shapes

谢谢提供链接。学习Ppt-VBA难点是思维转不过来。习惯绑定引用项，层级太多，晕晕乎乎。
Dim Txt As TextRange, TxtFrm As TextFrame, TxtEFormat As TextEffectFormat
左绕右绕层级这个知识点，快要人奔溃了。

Sub del21()
Dim Ppt As PowerPoint.Application
Dim Pres As Presentation
Dim Sld As Slide
Dim Shp As Shape
Dim ShpRng As ShapeRange
Dim TxtShp As Shape
Dim TxtFrm As TextFrame
Dim TxtRng As TextRange
Dim TxtEFmat As TextEffectFormat
Dim TxtSty As TextStyle
Dim Win As Window
Dim SldRng As SlideRange
'Dim Txt As TextRange, TxtFrm As TextFrame, TxtEFormat As TextEffectFormat
Set Ppt = New PowerPoint.Application
'Set Win = Ppt.ActiveWindow
Set Pres = Ppt.ActivePresentation
Set Sld = Pres.Slides(1)
For Each Shp In Sld.Shapes
If Shp.Type = msoTextBox Then
Set TxtFrm = Shp.TextFrame
If TxtFrm.HasText = True Then
Debug.Print TxtFrm.TextRange.Text
End If
Stop
End If
Next Shp

复制代码

************************************
SlideRange 对象 (PowerPoint) | Microsoft Learn  https://learn.microsoft.com/zh-c ... werpoint.sliderange

ShapeRange集合对象--------------用普通思路不好理解。

ShapeRange代表图形区域，该区域是文档中的一组图形。图形区域可包含一个图形，也可包含文档中的所有图形。可以在图形区域中包含所需的任意图形（在文档中的所有图形中选取，或在所有选定的图形中选取）。例如，可以构造包含文档中前三个图形、所有选定图形或所有任意多边形的 ShapeRange 集合。
关于如何使用一个形状或同时使用多个形状的概述，请参阅使用形状（绘图对象）。

ShapeRange.TextFrame 属性 (Excel) | Microsoft Learn  https://learn.microsoft.com/zh-c ... haperange.textframe
TextFram只有在Ppt有，Excel-VBA没有。

TextEffectFormat 对象 (PowerPoint) | Microsoft Learn  https://learn.microsoft.com/zh-c ... nt.texteffectformat

搞不清TextEffectFormat到底效果.

ning84 · 发表于 2023-2-1 14:55

ShapeRange 对象 (PowerPoint) | Microsoft Learn https://learn.microsoft.com/zh-cn/office/vba/api/powerpoint.shaperange

花了好长时间，也没有学会，ShapeRange怎么用。

Set myDocument = ActivePresentation.Slides(1)myDocument.Shapes.Range(Array(1, 3)).Fill _ .Patterned msoPatternHorizontalBrick

Sub ll()
Dim Ppt As PowerPoint.Application
Dim Pres As Presentation
Dim Sld As Slide
Dim Shp As Shape
Dim ShpRng As ShapeRange
Dim TxtRng As TextRange
Dim TxtFrm As TextFrame
Dim TxtEFrm As TextEffectFormat
Dim TxtSty As TextStyle
Set Ppt = New PowerPoint.Application
Set Pres = Ppt.ActivePresentation
Set Sld = Pres.Slides(1)
For Each Shp In Sld.Shapes
If Shp.Type = msoTextBox Then
Set TxtFrm = Shp.TextFrame
If TxtFrm.HasText = True Then
Set TxtRng = TxtFrm.TextRange
Debug.Print TxtRng.Text
Shp.TextFrame.TextRange.Text = "层级太多太复杂"
With Shp
.Left = 100
.Top = 350
.Width = 300
Debug.Print .Left, .Top
End With
''
With TxtFrm
.Orientation = msoTextOrientationVerticalFarEast
.Orientation = msoTextOrientationHorizontal
.WordWrap = msoTrue
With .TextRange
Debug.Print .Length, .BoundLeft, .BoundWidth
Debug.Print .Font.Shadow
.Font.Shadow = msoFalse
.Font.Size = 30
End With
End With
TxtFrm.TextRange.Font.Color.RGB = RGB(255, 255, 255)
'Set ShpRng = Sld.Shapes(1).Range(1)
Debug.Print Sld.Shapes.Range
Sld.Shapes.Range(Array(1, 3)).Fill.Patterned msoPatternHorizontalBrick
Stop
''
End If
End If
Next Shp
End Sub
Sub Macro1()
'
' 宏由 win 记录，日期: 2023/2/1
'
ActiveWindow.Selection.SlideRange.Shapes("Text Box 39").Select
With ActiveWindow.Selection.ShapeRange
.IncrementLeft -0.88
.IncrementTop -0.62
End With
ActiveWindow.Selection.SlideRange.Shapes("Object 23").Select
ActiveWindow.Selection.SlideRange.Shapes("Text Box 39").Select
With ActiveWindow.Selection.ShapeRange
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.RGB = RGB(153, 204, 255)
.Fill.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = ppForeground
.Line.BackColor.RGB = RGB(255, 255, 255)
End With
ActiveWindow.Selection.SlideRange.Shapes("Text Box 39").Select
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=8).Select
With ActiveWindow.Selection.TextRange.Font
.NameAscii = "Arial"
.NameOther = "Arial"
.NameFarEast = "华文行楷"
.Size = 30
.Bold = msoTrue
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoTrue
.Color.SchemeColor = ppForeground
End With
ActiveWindow.Selection.SlideRange.Shapes("Object 23").Select
ActiveWindow.Selection.SlideRange.Shapes("Text Box 39").Select
With ActiveWindow.Selection.ShapeRange
.Fill.Transparency = 0#
.Line.Weight = 1.5
.TextFrame.Orientation = msoTextOrientationVerticalFarEast
End With
ActiveWindow.Selection.Unselect
End Sub

复制代码

lss001 · 发表于 2023-2-1 17:50

本帖最后由 lss001 于 2023-2-2 10:44 编辑

ShapeRange 对象
一般操作选中的形状时使用, 表示选中的形状集合
Set SelShapeRng = ActiveWindows.Selection.ShapeRange '多个
Set SelShapeRng1 = ActiveWindows.Selection.ShapeRange(1) '单个

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