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

lizhipei78

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

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

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

ning84

zhu086 发表于 2024-9-28 22:03
你好，运行后，相册图片不见了，没看到添加水印后的图片，不知道是哪里的问题帮我看看，谢谢

1. Sub ImageProcessAddWatermarkToJPG()
   
2.      Dim Fd As FileDialog
   
3.      Dim FilePath As String
   
4.      Dim WatermarkText As String
   
5.      Dim objShell As Object
   
6.      Dim objExec As Object
   
7.      Dim command As String
   
8.      FilePath = "C:\2025年3月珠海\2025年3月17日翠景路(三台石-红山路)\Marki_20250317_085530625.jpg"
   
9.      
   
10.      ' 设置水印文字
    
11.     WatermarkText = "水印内容"
    
12.     ''
    
13.     Dim Fso As Scripting.FileSystemObject
    
14.         Set Fso = New Scripting.FileSystemObject
    
15.     Dim oFile As File
    
16.         Set oFile = Fso.GetFile(FilePath)
    
17.         Debug.Print oFile.Name
    
18.     Dim Img As WIA.ImageFile, ImgPro As WIA.ImageProcess
    
19.         Set Img = New WIA.ImageFile
    
20.         Set ImgPro = New WIA.ImageProcess
    
21.         Img.LoadFile oFile.Path
    
22.         
    
23.         ImgPro.Filters.Add ImgPro.FilterInfos("Stamp").FilterID
    
24.         'Set ImgPro.Filters(1).Properties("ImageFile") = Img
    
25.         
    
26.         With ImgPro.Filters(1)
    
27.             Set .Properties("ImageFile") = Img
    
28.             .Properties("Left") = 100
    
29.             .Properties("Top") = 10
    
30.         End With
    
31.    Dim NewImg As WIA.ImageFile
    
32.        Set NewImg = ImgPro.Apply(Img)
    
33.        NewImg.SaveFile "C:\1.jpg"
    
34. 
    
35.         
    
36. End Sub
    
37. 
    
38. 
    
39. 
    

复制代码

程序调试通过，但找不到水印。