关于vba批量添加水印，修改代码

lizhipei78

用WSHShell 自动获取桌面路径，你再试试看

添加水印并覆盖原文件.rar (18.52 KB, 下载次数: 22)

2024-9-27 19:57 上传

点击文件名下载附件

zhu086

lizhipei78 发表于 2024-9-27 19:57
用WSHShell 自动获取桌面路径，你再试试看

万分感谢，已经没问题了

lizhipei78

icenotcool 发表于 2024-9-27 17:24
各位老师，可以看看我的贴吗？该怎么修改，
Sub Total()
    Set d = CreateObject("scripting.dictionar ...

你这个要怎么改？需求是什么，有附件吗？

icenotcool

lizhipei78 发表于 2024-9-27 21:56
你这个要怎么改？需求是什么，有附件吗？

有附件的，老师，这个是我的帖子，麻烦您啦，【新提醒】跨表提取不重复数据并按条件汇总（去重求和）-Excel VBA程序开发-ExcelHome技术论坛 -  https://club.excelhome.net/thread-1702629-1-1.html

lizhipei78

使用FSO重新一个，不用创建临时文件夹，可能快一点点

zhu086

lizhipei78 发表于 2024-9-28 09:35
使用FSO重新一个，不用创建临时文件夹，可能快一点点

你好，运行后，相册图片不见了，没看到添加水印后的图片，不知道是哪里的问题帮我看看，谢谢


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm As Double
tm = Timer
Dim WSHShell As Object
Set WSHShell = CreateObject("wscript.shell")
Dim deskPath As String
deskPath = WSHShell.SpecialFolders("Desktop") '也可以自己设置桌面路径
Dim FSO As Object
Set FSO = CreateObject("scripting.Filesystemobject")
Dim p As String, p1 As String
p = deskPath & "\相册" '图片所在位置
p1 = deskPath '水印位置
Dim f As Object
For Each f In FSO.GetFolder(p).Files
    On Error Resume Next '避免加载不是图片的错误
    Dim strPath As String
    strPath = f.Path
    Dim 图 As Object, 水印 As Object
    Set 图 = CreateObject("WIA.ImageFile")
    Set 水印 = CreateObject("WIA.ImageFile")
    图.LoadFile strPath
    水印.LoadFile p1 & "\水印.png"
    Dim 合成图 As Object
    Set 合成图 = CreateObject("WIA.ImageProcess")
    合成图.Filters.Add 合成图.FilterInfos("stamp").FilterID
    Set 合成图.Filters(1).Properties("ImageFile") = 水印
    合成图.Filters(1).Properties("Left") = 图.Width - 水印.Width
    合成图.Filters(1).Properties("Top") = 水印.Height
    Dim 新图 As Object
    Set 新图 = 合成图.Apply(图)
    FSO.deletefile strPath, True
    新图.SaveFile strPath
Next
MsgBox "完毕，共用时:  " & Format(Timer - tm, "0.000秒"), , "提示"
Application.ScreenUpdating = True
Application.DisplayAlerts = True