在ppt中实时显示面积或者其他信息。
本帖最后由 etkane 于 2024-11-1 16:53 编辑PPT的事件第一次研究，花了些功夫。
代码分三部分，实现的效果就是实时显示面积（利用图形长宽）
改改显示的内容，理论可以实时显示需要的任何信息。
’更新描述：2024/11/01
更新代码，可以多选了：更新如下，为显示面积子程序。同时删除或者注释掉类里面的下列代码：
'Private Sub App_AfterShapeSizeChange(ByVal shp As Shape)
' 显示面积
'End Sub
'
'Private Sub App_WindowBeforeRightClick(ByVal Sel As Selection, Cancel As Boolean)
' 显示面积
'End Sub
更新代码如下：这是模块里的代码，不要搞错。
Sub 显示面积()
Dim sr As ShapeRange
'shuchu As String
If ActiveWindow.Selection.Type <> ppSelectionShapes Then
'Debug.Print "没有选择内容"
If Not IsShapeExist("面积显示") Then
Application.ActiveWindow.View.Slide.Shapes("面积显示").TextFrame.TextRange.text = ""
End If
Debug.Print ("没选择")
GoTo out
End If
'Debug.Print IsError(ActiveWindow.Selection.ShapeRange)
On Error Resume Next
Set sr = ActiveWindow.Selection.ShapeRange
For m = 1 To sr.Count
Dim area As Double
Dim k As Double
Dim gAs Double
Dim text As String
k = Round(sr(m).Width / 28.3464565, 2) * 10
g = Round(sr(m).Height / 28.3464565, 2) * 10
area = Round(k * g, 2)
heji = heji + area
If IsShapeExist("面积显示") Then
'Debug.Print "fbucunzai"
Dim sd As Slide
Set sd = Application.ActiveWindow.View.Slide
With sd.Shapes.AddTextbox(1, 10, 50, 40, 150)
.Name = "面积显示"
.Fill.ForeColor.RGB = RGB(211, 211, 211)
.TextEffect.FontSize = 8
End With
Else
'Debug.Print "cunzai"
End If
shuchu = shuchu + sr(m).Name & Chr(10) & "东西：" & k & Chr(10) & _
"南北：" & g & Chr(10) & _
"面：" & area & Chr(10)
Next m
Application.ActiveWindow.View.Slide.Shapes("面积显示").TextFrame.TextRange.text = shuchu & "合计：" & heji
Debug.Print (shuchu)
out:
End Sub
更新效果图：
’更新描述结束：2024/11/01
原始发布版本内容描述：
‘------------------------------------这一部分放到模块里
Dim X As New 类1
Sub 显面积()
Set X.App = Application
End Sub
’----------------------------------这些放到类模块里，注意类模块改名 类1（这个耽误了我接近一下午）。
Public WithEvents App As Application
Private Sub App_AfterShapeSizeChange(ByVal shp As Shape)
显示面积
End Sub
Private Sub App_WindowBeforeRightClick(ByVal Sel As Selection, Cancel As Boolean)
显示面积
End Sub
Private Sub App_WindowSelectionChange(ByVal Sel As Selection)
显示面积
End Sub
’----------------------------------这些放哪里都行，我是放模块里
Sub 显示面积()
Dim sr As ShapeRange
If ActiveWindow.Selection.Type <> ppSelectionShapes Then
Debug.Print "没有选择内容"
If Not IsShapeExist("面积显示") Then
Application.ActiveWindow.View.Slide.Shapes("面积显示").TextFrame.TextRange.text = ""
End If
GoTo out
End If
'Debug.Print IsError(ActiveWindow.Selection.ShapeRange)
On Error Resume Next
Set sr = ActiveWindow.Selection.ShapeRange
Dim area As Double
Dim k As Double
Dim gAs Double
Dim text As String
k = Round(sr.Width / 28.3464565, 2) * 10
g = Round(sr.Height / 28.3464565, 2) * 10
area = Round(k * g, 2)
If IsShapeExist("面积显示") Then
Debug.Print "fbucunzai"
Dim sd As Slide
Set sd = Application.ActiveWindow.View.Slide
With sd.Shapes.AddTextbox(1, 10, 50, 40, 150)
.Name = "面积显示"
.Fill.ForeColor.RGB = RGB(211, 211, 211)
.TextEffect.FontSize = 8
End With
Else
Debug.Print "cunzai"
Application.ActiveWindow.View.Slide.Shapes("面积显示").TextFrame.TextRange.text = _
"东西：" & k & Chr(10) & _
"南北：" & g & Chr(10) & _
"面：" & area
End If
out:
End Sub
Function IsShapeExist(shapeName As String) As Boolean
Dim shp As Shape
On Error Resume Next ' 开始错误处理，防止找不到shape时产生错误
Set shp = Application.ActiveWindow.View.Slide.Shapes(shapeName)
On Error GoTo 0 ' 错误处理结束
IsShapeExist = shp Is Nothing' 如果shape存在，返回True
End Function
显示什么面积 拖放的模块吗 感谢分享，下载研究一下先 提供了一种思路，谢谢分享。 学习了，可以开发相关软件 对于数学老师用途不小试试看 感谢分享 耍出高度，耍出花样 很好用的样子。。。 建议有用这个小程序的，更新代码。
页:
[1]