随机插入文件夹内图片

leeson7502

gtbb2002 发表于 2023-12-9 19:44
会不会是电脑问题，第一张显示后没有消失，立即跳到第二张，而且前面图面一直叠加

原因就是图片没有被删除，那就是图片类型的值，在你的电脑上不是11,可能是13
有个删除图片的过程，Sub deletePicture()
把：If pic.Type = 11 Then，改为If pic.Type = 13 Then,试试

lizhipei78

展示图片，干嘛不用图片软件，随便一个图片工具都有这个功能
干嘛要跟Excel过不去

liulang0808

Dim t, d, rng, y
Sub 按钮1_Click()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set d = CreateObject("Scripting.dictionary")
    For Each f In fso.getfolder(ThisWorkbook.Path).Files
        If LCase(fso.getextensionname(f)) = "jpg" Then
            d(f.Name) = f
        End If
    Next f
    Set rng = [d4:e14]
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 13 Then shp.Delete
    Next shp
    Call 时间1
End Sub


Sub 时间1()
    If d.Count <> 0 Then
        x = WorksheetFunction.RandBetween(0, d.Count - 1)
        k = d.keys()(x)
        f = d(k)
        ActiveSheet.Shapes.addpicture f, msoFalse, msoCTrue, rng.Left + 1, rng.Top + 1, rng.Width - 2, rng.Height - 2
        d.Remove k
        y = 2
        t = Now() + TimeValue("00:00:02")
        Application.OnTime t, "时间2"
    Else
        MsgBox "所有图片循环完成！"
        End
    End If
End Sub

Sub 时间2()
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 13 Then shp.Delete
    Next shp
    y = 1
    t = Now() + TimeValue("00:00:03")
    Application.OnTime t, "时间1"
End Sub

Sub 终止()
    If y = 1 Then
        Application.OnTime t, "时间1", , False
    Else
        Application.OnTime t, "时间2", , False
    End If
End Sub

liulang0808

新建文件夹 (16).zip (214.76 KB, 下载次数: 34)

2023-12-10 12:37 上传

点击文件名下载附件

简单模拟了一个，就是之前得那些资料堆砌得，界面根据自己需求修改吧

gtbb2002

liulang0808 发表于 2023-12-10 12:37
简单模拟了一个，就是之前得那些资料堆砌得，界面根据自己需求修改吧

感谢版主，感恩！效果良好，孩子可以短时间记忆，继续下一次，达到理想效果。