[已解决]求自动加密

tayisha

现在遇到一个自动加密文件的困难，求一个自动加密宏，具体见附件

最佳答案

月排行榜 / 总排行榜

suye1010

2014-11-14 14:35

1. Dim EAPP,YBwb,MMwb,TEMPwb,i,j,d,FN,Arr,Shell, FinalFilePath,Prefix
   
2. Set EAPP=CreateObject("Excel.Application")
   
3. 
   
4. FN=EAPP.GetOpenFilename("Excel Files(*.xls;*.xlsx),*.xls;*.xlsx,All Files(*.*),*.*",,"请选择源表",False)
   
5. If FN=False Then
   
6. Wscript.Quit
   
7. End If
   
8. Set YBwb = EAPP.Workbooks.Open(FN)
   
9. Arr= YBwb.Sheets(1).Cells(1,1).CurrentRegion
   
10. YBwb.Close False
    
11. 
    
12. FN=EAPP.GetOpenFilename("Excel Files(*.xls;*.xlsx),*.xls;*.xlsx,All Files(*.*),*.*",,"请选择密码文件", False)
    
13. If FN=False Then
    
14. Wscript.Quit
    
15. End if
    
16. Set MMwb = EAPP.Workbooks.Open(FN)
    
17. Set d= CreateObject("Scripting.Dictionary")
    
18. For i= 1 to MMwb.Sheets(1).Cells(1,1).CurrentRegion.Rows.Count
    
19. d(MMwb.Sheets(1).Cells(i,1).Value)= MMwb.Sheets(1).Cells(i,2).Value
    
20. Next
    
21. MMwb.Close False
    
22. 
    
23. Set Shell = CreateObject("Shell.Application")
    
24. Set FinalFilePath = Shell.BrowseForFolder(0, "请选择存储加密后工作表的文件夹", 0, 0)
    
25. If FinalFilePath Is Nothing Then
    
26. Wscript.Quit
    
27. End If
    
28. 
    
29. Prefix = InputBox("请输入测验成绩单的周数", "测验周数")
    
30. If Len(Prefix) = 0 Then
    
31. Wscript.Quit
    
32. End If
    
33. 
    
34. For i=2 to UBound(Arr)
    
35. Set TEMPwb=EAPP.Workbooks.Add
    
36. For j=1 to UBound(Arr,2)
    
37. TEMPwb.Sheets(1).Cells(1,j)=Arr(1,j)
    
38. TEMPwb.Sheets(1).Cells(2,j)=Arr(i,j)
    
39. Next
    
40. TEMPwb.Password=d(Arr(i,1))
    
41. TEMPwb.Close True,FinalFilePath.self.Path&"/"&Prefix&"-"&Arr(i,1)&".xlsx"
    
42. Next
    
43. 
    
44. Msgbox "已完成文件加密"
    
45. EAPP.Quit

复制代码

只需要源表和密码表就可以，第2步也让程序自动处理了。复制代码到记事本，另存为.vbs的文件后双击运行即可。
加密成绩单.zip (746 Bytes, 下载次数: 31)

2014-11-14 14:34 上传

点击文件名下载附件

跳转到最佳答案楼层

suye1010

1. Dim EAPP,YBwb,MMwb,TEMPwb,i,j,d,FN,Arr,Shell, FinalFilePath,Prefix
   
2. Set EAPP=CreateObject("Excel.Application")
   
3. 
   
4. FN=EAPP.GetOpenFilename("Excel Files(*.xls;*.xlsx),*.xls;*.xlsx,All Files(*.*),*.*",,"请选择源表",False)
   
5. If FN=False Then
   
6. Wscript.Quit
   
7. End If
   
8. Set YBwb = EAPP.Workbooks.Open(FN)
   
9. Arr= YBwb.Sheets(1).Cells(1,1).CurrentRegion
   
10. YBwb.Close False
    
11. 
    
12. FN=EAPP.GetOpenFilename("Excel Files(*.xls;*.xlsx),*.xls;*.xlsx,All Files(*.*),*.*",,"请选择密码文件", False)
    
13. If FN=False Then
    
14. Wscript.Quit
    
15. End if
    
16. Set MMwb = EAPP.Workbooks.Open(FN)
    
17. Set d= CreateObject("Scripting.Dictionary")
    
18. For i= 1 to MMwb.Sheets(1).Cells(1,1).CurrentRegion.Rows.Count
    
19. d(MMwb.Sheets(1).Cells(i,1).Value)= MMwb.Sheets(1).Cells(i,2).Value
    
20. Next
    
21. MMwb.Close False
    
22. 
    
23. Set Shell = CreateObject("Shell.Application")
    
24. Set FinalFilePath = Shell.BrowseForFolder(0, "请选择存储加密后工作表的文件夹", 0, 0)
    
25. If FinalFilePath Is Nothing Then
    
26. Wscript.Quit
    
27. End If
    
28. 
    
29. Prefix = InputBox("请输入测验成绩单的周数", "测验周数")
    
30. If Len(Prefix) = 0 Then
    
31. Wscript.Quit
    
32. End If
    
33. 
    
34. For i=2 to UBound(Arr)
    
35. Set TEMPwb=EAPP.Workbooks.Add
    
36. For j=1 to UBound(Arr,2)
    
37. TEMPwb.Sheets(1).Cells(1,j)=Arr(1,j)
    
38. TEMPwb.Sheets(1).Cells(2,j)=Arr(i,j)
    
39. Next
    
40. TEMPwb.Password=d(Arr(i,1))
    
41. TEMPwb.Close True,FinalFilePath.self.Path&"/"&Prefix&"-"&Arr(i,1)&".xlsx"
    
42. Next
    
43. 
    
44. Msgbox "已完成文件加密"
    
45. EAPP.Quit

复制代码

只需要源表和密码表就可以，第2步也让程序自动处理了。复制代码到记事本，另存为.vbs的文件后双击运行即可。
加密成绩单.zip (746 Bytes, 下载次数: 31)

2014-11-14 14:34 上传

点击文件名下载附件

tayisha

suye1010 发表于 2014-11-14 14:35
只需要源表和密码表就可以，第2步也让程序自动处理了。复制代码到记事本，另存为.vbs的文件后双击运行即可。 ...

太谢谢了，就是我要的

tayisha

上面的宏不知道咋地不能用了，求改善