批量给WORD文档添加身份证号后6位为打开文件密码？

batmanbbs

文档我已经用WORD打开后保存了一下。

wdpfox

batmanbbs 发表于 2023-6-2 19:44

如果是word宏程序，该如何编程呢？

batmanbbs

wdpfox 发表于 2023-6-4 16:52
如果是word宏程序，该如何编程呢？

这个不就是宏吗？你的意思是不是想弄一个按钮，点击后直接执行代码？

wdpfox

老师，你编的宏秸序放在excel中，还是word文档中，我的意思是word宏，批骨打开word文档，根据文档名，查找Excel文档中的同名对应的18位身份证号，再以后六位设为word密码

batmanbbs

根据你的要求，其实放在EXCEL更加适合，因为如果放在WORD文档中的话，你准备放在那个文档中呢，一个空白文档？
当然，如果放在WORD中也可以，开头读取EXCEL的数据的那部分，改成按照后面WORD初始定义的方式，打开EXCEL文档，除了对象不同外，基本没有什么区别。

batmanbbs

wdpfox 发表于 2023-6-4 21:02
老师，你编的宏秸序放在excel中，还是word文档中，我的意思是word宏，批骨打开word文档，根据文档名，查找E ...

1. Sub 批量设置WORD文档密码()
   
2. '
   
3. ' 批量设置WORD文档密码(WORD版)
   
4. ' 1.加密表确保A列为姓名（WORD文档名，不得重名），B列为密码
   
5. ' 2.姓名和密码前后有空格会被删除，中间空格不会被删除
   
6. ' 3.WORD文档和EXCEL加密表在同一目录下
   
7. '
   
8.     Dim FileName$, PassWord$, Count%, i%
   
9.     Dim xlApp, xlwb As Object
   
10.     Dim Dict As Object, Key$, Msg$
    
11.     Dim myDoc As Document, File As Variant
    
12.     Const PWLen As Byte = 6        ' 密码长度（可根据实际修改）
    
13. 
    
14.     With Application.FileDialog(msoFileDialogFilePicker)
    
15.         .Filters.Clear
    
16.         .Filters.Add "WORD文档", "*.doc; *.docx", 1
    
17.         .AllowMultiSelect = True
    
18.         If .Show <> -1 Then End
    
19.         FileName = .SelectedItems(1)
    
20.         FileName = Left(FileName, InStrRev(FileName, ""))
    
21.         FileName = FileName & "加密.xlsm"        ' 可根据实际修改加密文件名：加密.xlsm
    
22.         'Debug.Print FileName
    
23.         If Len(Dir(FileName)) = 0 Then MsgBox FileName & " 文件不存在！": End
    
24. 
    
25.         Set Dict = CreateObject("Scripting.Dictionary")
    
26.         Set xlApp = CreateObject("Excel.Application")
    
27.         'xlApp.Visible = True
    
28.         Set xlwb = xlApp.Workbooks.Open(FileName, ReadOnly:=True)
    
29.         With xlwb.WorkSheets("Sheet1")        ' 可根据实际修改密码工作表名：Sheet1
    
30.             Count = .Cells(.Rows.Count, 1).End(-4162).Row
    
31.             For i = 2 To Count        ' 无标题行：2改成1
    
32.                 Key = Trim(.Cells(i, 1).Value)        ' 第1列为姓名（文件名）：注意绝对不能有重名！
    
33.                 Dict(Key) = Right(Trim(.Cells(i, 2).Value), PWLen)        ' 第2列为身份证号码（位置可修改)
    
34.                 'Debug.Print Key, Dict(Key)
    
35.             Next i
    
36.         End With
    
37.         xlwb.Close False
    
38.         xlApp.Quit
    
39.         Set xlwb = Nothing
    
40.         Set xlApp = Nothing
    
41. 
    
42.         For Each File In .SelectedItems
    
43.             On Error GoTo Error
    
44.             Set myDoc = Documents.Open(File)
    
45.             If myDoc Is Nothing Then
    
46.                 MsgBox File & Msg
    
47.             Else
    
48.                 Key = myDoc.Name
    
49.                 Key = Trim(Left(Key, InStrRev(Key, ".") - 1))
    
50.                 PassWord = Dict(Key)
    
51.                 'Debug.Print Key, PassWord
    
52.                 If Len(PassWord) <> PWLen Then
    
53.                     MsgBox "未找到" & Key & " 或 密码不规范！"
    
54.                 Else
    
55.                     With myDoc
    
56.                         .ReadOnlyRecommended = False
    
57.                         .PassWord = PassWord
    
58.                         .Close True
    
59.                     End With
    
60.                     Set myDoc = Nothing
    
61.                 End If
    
62.             End If
    
63.         Next File
    
64.     End With
    
65. 
    
66.     Set Dict = Nothing
    
67.     MsgBox "已完成批量加密！"
    
68.     End
    
69. 
    
70. Error:
    
71.     'Debug.Print Err.Number
    
72.     Select Case Err.Number
    
73.     Case 4198
    
74.         Msg = " 已加密并跳过！"
    
75.     Case 6295
    
76.         Msg = " 格式有问题！"
    
77.     Case 6301
    
78.         Msg = " 已打开（关闭后才能加密）！"        ' 因为无法确定如有修改是否应该保存
    
79.     Case Else
    
80.         Msg = " 打开错误！"
    
81.     End Select
    
82.     On Error GoTo 0: Err.Clear
    
83.     Resume Next
    
84. End Sub

复制代码

batmanbbs

补充几点：
1. 代码不会修改任何数据，只是在识别姓名（文件名）和设置密码时，会忽略前后空格（中间空格不会省略，如也需忽略，请使用 REPLACE 过滤一下）
2. 密码是获取身份证的后6位，如果少于6位不会设置密码
3. 如果姓名（文件名）真的有重名，密码是重名中最后一个姓名（文件名）对应的密码
4. 没有对已经打开的文档进行加密，因为无法判断如果文档修改了，修改的内容是否真的需要保存。如果不考虑这个问题，在判断后可以使用 Set myDoc = Documents(File) 后执行加密
5. 这次的代码是在EXCEL版的批量设置密码的基础进行完善的，考虑的情况更多一些，相关代码也可以复制到EXCEL版的代码中使用

wdpfox

batmanbbs 发表于 2023-6-5 01:10

感谢老师提供学习代码的机会，愿好人一生平安快乐！

batmanbbs

我也在学习啊，注意：第20句""中间应该有一个\，被吃掉了

另外，82句放到45句的位置更加合理，代码总需要审核，我就不更新了，自己修改一下

wdpfox

如此标准的代码真值得我学习，谢谢！


★★★★★ 【抛去所谓的敬畏之心，你会重新认知这个世界。】 ★★★★★