|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 gbabc 于 2023-3-29 15:07 编辑
用的是Microsoft PowerPoint 2016,想弄个抽奖程序,要求:在当前页面,创建一个显示框,当点击开始按钮时,框内随机滚动显示本地文件夹内的图片。当点击停止按钮时,停止滚动。实测代码无法运行,请各位大佬指点,先谢了。
- Sub 创建抽奖框()
- Dim shp As Shape
- Dim btn1 As Shape
- Dim btn2 As Shape
- Dim rng As Range
- Dim picName As String
-
- '创建一个显示框
- Set shp = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 100, 100, 500, 300)
- shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
- shp.Line.ForeColor.RGB = RGB(0, 0, 0)
-
- '创建一个开始按钮,并分配宏
- Set btn1 = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRoundedRectangle, 150, 450, 100, 50)
- btn1.Fill.ForeColor.RGB = RGB(0, 255, 0)
- btn1.Line.ForeColor.RGB = RGB(0, 0, 0)
- btn1.TextFrame.TextRange.Text = "开始"
- btn1.ActionSettings(ppMouseClick).Run = "开始"
-
- '创建一个停止按钮,并分配宏
- Set btn2 = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRoundedRectangle, 450, 450, 100, 50)
- btn2.Fill.ForeColor.RGB = RGB(255, 0, 0)
- btn2.Line.ForeColor.RGB = RGB(0, 0, 0)
- btn2.TextFrame.TextRange.Text = "停止"
- btn2.ActionSettings(ppMouseClick).Run = "停止"
-
- End Sub
- Sub 开始()
- '设置图片的路径和文件夹
- Const picPath As String = "D:\抽奖图片"
- Const picFolder As String = "抽奖图片"
-
- '获取图片的文件名列表
- Dim picList() As String
- Dim picCount As Long
- Dim fso As Object
- Dim fld As Object
- Dim fil As Object
-
- Set fso = CreateObject("Scripting.FileSystemObject")
- Set fld = fso.GetFolder(picPath)
-
- For Each fil In fld.Files
- If UCase(fil.Name) Like "*.JPG" Or UCase(fil.Name) Like "*.PNG" Then
- ReDim Preserve picList(picCount)
- picList(picCount) = fil.Name
- picCount = picCount + 1
- End If
- Next fil
-
- '随机选择一个图片文件名,并插入到显示框中
- Dim shp As Shape
- Dim rng As Range
- Dim picName As String
-
- Set shp = ActivePresentation.Slides(1).Shapes(1) '假设显示框是第一个形状,可以根据需要修改
-
- Randomize '初始化随机数种子
-
- Do While SlideShowWindows.Count > 0 '当幻灯片放映时,循环执行以下代码
-
- '删除原有的图片(如果有)
- On Error Resume Next
- shp.Shapes(1).Delete
-
- '随机选择一个图片文件名,并拼接完整的路径
- picName = picList(Int(Rnd * picCount))
- picName = picPath & picName
-
- '在显示框中插入图片,并调整位置和大小
- With shp.Shapes.AddPicture(picName, False, True, -1, -1, -1, -1)
- .LockAspectRatio = msoTrue '保持纵横比
-
- If .Height / .Width > shp.Height / shp.Width Then '根据显示框和图片的纵横比,确定缩放比例
- .Height = shp.Height - 10 '留出一些边距
- .Left = shp.Left + (shp.Width - .Width) / 2 '水平居中
- .Top = shp.Top + 5 '垂直居上
- Else
- .Width = shp.Width - 10 '留出一些边距
- .Top = shp.Top + (shp.Height - .Height) / .Left = shp.Left + 5 '水平居左
- End If
- End With
-
- DoEvents '处理其他事件,例如点击停止按钮
-
- Loop
-
- End Sub
- Sub 停止()
- '停止幻灯片放映
- SlideShowWindows(1).View.State = ppSlideShowDone
- End Sub
复制代码
|
|