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

zhu086 · 发表于 2024-9-27 15:32

本帖最后由 zhu086 于 2024-10-1 19:30 编辑

现在的代码是批量添加选择文件夹，添加随机水印

有没有大佬帮我改下代码，谢谢

需求：唯一水印C:\Users\Administrator\Desktop\水印.png
要处理的文件夹C:\Users\Administrator\Desktop\相册
水印显示在右上角
处理后的图片覆盖原图片

Sub 图片批量添加水印()
Dim T, R%, j%, i, Myfile, p$, f$, Arr, Brr
T = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Myfile = Dir(ThisWorkbook.Path & "\*.png")
ReDim Arr(1 To 500)
ReDim Brr(1 To 500)
Do While Myfile <> ""
      R = R + 1
      Arr(R) = Myfile
      Brr(R) = Split(Arr(R), ".")(0)
      Myfile = Dir
Loop
For i = 1 To R
      dir_name = ThisWorkbook.Path & "\" & Brr(i) & "\"
      If Dir(dir_name, vbDirectory) = "" Then MkDir (dir_name)
Next
With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "请选择文件夹"
      .InitialFileName = ThisWorkbook.Path & ""
      If .Show Then p = .SelectedItems(1) & "\" Else MsgBox "你没有选择文件夹": GoTo 100
End With
f = Dir(p & "*.*")
Do While f <> ""
      Set 图 = CreateObject("WIA.ImageFile")
      Set 水印 = CreateObject("WIA.ImageFile")
      图.LoadFile p & f
      For i = 1 To R
         wh = ""
         Dirname = ThisWorkbook.Path & "\" & Brr(i) & "\" & f
         On Error Resume Next
         Set 判断 = CreateObject("WIA.ImageFile")
         判断.LoadFile Dirname
         wh = 判断.Width
         If Len(wh) Then GoTo 50
         水印.LoadFile ThisWorkbook.Path & "\" & Arr(i)
         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 - 水印.Height
         Set 新图 = 合成图.Apply(图)
         新图.SaveFile ThisWorkbook.Path & "\" & Brr(i) & "\" & f
50
      Next
      f = Dir
Loop
Beep
MsgBox "完毕，共用时： " & Format(Timer - T, "0.000秒"), , "提示"
100
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

批量添加水印.rar (18.02 KB, 下载次数: 18)

lizhipei78 · 发表于 2024-9-27 16:23

这个是我写的，我看看还记不记得当时的思路

zhu086 · 发表于 2024-9-27 16:56

lizhipei78 发表于 2024-9-27 16:23
这个是我写的，我看看还记不记得当时的思路

哈哈哈，看来你还是在这里的多，我吾爱@你没回复

icenotcool · 发表于 2024-9-27 17:22

本帖最后由 icenotcool 于 2024-9-27 21:48 编辑

各位老师，可以看看我的求助贴吗？跨表提取不重复数据并按条件汇总（去重求和）-Excel VBA程序开发-ExcelHome技术论坛 - https://club.excelhome.net/forum ... ra=&_dsign=91595a5e

icenotcool · 发表于 2024-9-27 17:24

各位老师，可以看看我的贴吗？该怎么修改，
Sub Total()
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
arr = Sheets("系统导出").UsedRange
r = 0
For j = 1 To UBound(arr)
      If arr(j, 9) = "金额" Then
         If d.exists(arr(j, 9) & "") Then
            X = d(arr(j, 9) & "")
            arr(X, 6) = arr(X, 6) + arr(j, 6)
         Else
            r = r + 1
            d(arr(j, 9) & "") = r
            arr(r, 1) = arr(j, 1)
            arr(r, 2) = arr(j, 2)
            arr(r, 3) = arr(j, 3)
            arr(r, 4) = arr(j, 8)
            arr(r, 5) = arr(j, 7)
            arr(r, 6) = arr(j, 9)
         End If
      End If
Next j
If r > 0 Then [A1].Resize(r, 6) = arr
Application.ScreenUpdating = True
End Sub

lizhipei78 · 发表于 2024-9-27 17:30

请测试

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

lizhipei78 · 发表于 2024-9-27 17:31

zhu086 发表于 2024-9-27 16:56
哈哈哈，看来你还是在这里的多，我吾爱@你没回复

那边不允许发VBA相关的，版主删除我上诉还给了一个违规，所以就很少去了。

zhu086 · 发表于 2024-9-27 19:08

lizhipei78 发表于 2024-9-27 17:30
请测试

水印显示找不到，帮我看下，谢谢

我确认了，在桌面上放个水印.png

GG函数 · 发表于 2024-9-27 19:15

直接用光影魔术手.exe ，52pj论坛多的是，也可以找我要

lizhipei78 · 发表于 2024-9-27 19:55

zhu086 发表于 2024-9-27 19:08
水印显示找不到，帮我看下，谢谢

我确认了，在桌面上放个水印.png

不好意思，漏了一个斜线
水印.LoadFile p1 & "\水印.png"

		自动登录	找回密码
密码			免费注册

[已解决] 关于vba批量添加水印，修改代码

评分