求助批量给不同版本的Excel设置读取和修改密码

zc403512688

给文件夹“待加密文件”内的Excel文件批量加密。要设置两个密码，读取和修改密码。然后Excel文件有2003版本的*.xls，也有2007后的版本*.xlsx
求大神帮看看，写个VBA代码。密码在放在“文件密码”的B和C列。A列希望能读取文件夹“待加密文件”内的文件名，然后用B列和C的密码给各个文件设置读取和修改密码。非常感谢！

3190496160

读取密码，应该是工作表保护密码，也就是打开密码，但是，修改密码是什么意思？还有，工作表空空如洗

zc403512688

3190496160 发表于 2024-7-26 09:53
读取密码，应该是工作表保护密码，也就是打开密码，但是，修改密码是什么意思？还有，工作表空空如洗

一般文件的读取密码是打开文件的密码。修改密码就是，不允许编辑，想要编辑文件就要输入修改密码。文件空的，主要是只是例子文件。要的就是给他加密读取和修改密码就是了哈，谢谢大神了
是批量设置图片的这两个密码

边缘码农

铁马1980

这两天刚好给朋友用jsa做了个批量加密的工具，修改了下，如果你有wps可以试试看。

批量自动加密.zip (13.53 KB, 下载次数: 10)

2024-7-26 11:44 上传

点击文件名下载附件

zc403512688

铁马1980 发表于 2024-7-26 11:44
这两天刚好给朋友用jsa做了个批量加密的工具，修改了下，如果你有wps可以试试看。

谢谢啦。主要是用office，不用WPS。

zc403512688

Sub 加密()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For i = 2 To Range("A65536").End(3).Row
        FLE = ThisWorkbook.Path & "\" & Cells(i, 1) & ".xls"
        PW = Cells(i, 2)
        RW = Cells(i, 3)
        With Workbooks.Open(FLE)
            .SaveAs Filename:=FLE, FileFormat:=xlNormal, Password:=PW, WriteResPassword:=RW
            .Close
        End With
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "处理完毕!"
End Sub
我有代码，但是这个代码只能用于Excel2003,2007的版本文件加密后会造成文件损坏无法打开，有没有大神帮改一下，能在Excel2003及2007各个版本都能使用。

zc403512688

顶一个，看看有没有大神帮看看，谢谢了

zc403512688

求助求助，哪个大神帮看看，非常感谢了

zc403512688

问题已经解决，感谢社区的大神，分享代码给大家

1. Sub ykcbf()    '//2024.8.5     工作簿加密
   
2.     Dim fn, wb
   
3.     Application.DisplayAlerts = False
   
4.     Application.ScreenUpdating = False
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     p = ThisWorkbook.Path & ""
   
8.     r = Cells(Rows.Count, 1).End(3).Row
   
9.     For i = 2 To r
   
10.         s = Cells(i, 1)
    
11.         If s <> Empty Then d(s) = Array(Cells(i, 2), Cells(i, 3))
    
12.     Next
    
13.     For Each f In fso.GetFolder(p).Files
    
14.         If LCase$(f.Name) Like "*.xls*" Then
    
15.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
16.                 fn = fso.GetBaseName(f)
    
17.                 fx = fso.GetExtensionName(f)
    
18.                 If InStr(fx, "xlsx") Then mm = 51 Else mm = 56
    
19.                 If d.exists(fn) Then
    
20.                     PW = d(fn)(0)
    
21.                     RW = d(fn)(1)
    
22.                     With Workbooks.Open(f)
    
23.                         .SaveAs Filename:=f, FileFormat:=mm, Password:=PW, WriteResPassword:=RW
    
24.                         .Close
    
25.                     End With
    
26.                 End If
    
27.             End If
    
28.         End If
    
29.     Next f
    
30.     Application.DisplayAlerts = True
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "处理完毕!"
    
33. End Sub
    

复制代码