|
42学分
本帖最后由 tayisha 于 2014-12-12 15:34 编辑
现在遇到一个自动加密文件的困难,求一个自动加密宏,具体见附件
本帖最后由 suye1010 于 2014-11-14 15:19 编辑
- Dim EAPP,YBwb,MMwb,TEMPwb,i,j,d,FN,Arr,Shell, FinalFilePath,Prefix
- Set EAPP=CreateObject("Excel.Application")
- FN=EAPP.GetOpenFilename("Excel Files(*.xls;*.xlsx),*.xls;*.xlsx,All Files(*.*),*.*",,"请选择源表",False)
- If FN=False Then
- Wscript.Quit
- End If
- Set YBwb = EAPP.Workbooks.Open(FN)
- Arr= YBwb.Sheets(1).Cells(1,1).CurrentRegion
- YBwb.Close False
- FN=EAPP.GetOpenFilename("Excel Files(*.xls;*.xlsx),*.xls;*.xlsx,All Files(*.*),*.*",,"请选择密码文件", False)
- If FN=False Then
- Wscript.Quit
- End if
- Set MMwb = EAPP.Workbooks.Open(FN)
- Set d= CreateObject("Scripting.Dictionary")
- For i= 1 to MMwb.Sheets(1).Cells(1,1).CurrentRegion.Rows.Count
- d(MMwb.Sheets(1).Cells(i,1).Value)= MMwb.Sheets(1).Cells(i,2).Value
- Next
- MMwb.Close False
- Set Shell = CreateObject("Shell.Application")
- Set FinalFilePath = Shell.BrowseForFolder(0, "请选择存储加密后工作表的文件夹", 0, 0)
- If FinalFilePath Is Nothing Then
- Wscript.Quit
- End If
- Prefix = InputBox("请输入测验成绩单的周数", "测验周数")
- If Len(Prefix) = 0 Then
- Wscript.Quit
- End If
- For i=2 to UBound(Arr)
- Set TEMPwb=EAPP.Workbooks.Add
- For j=1 to UBound(Arr,2)
- TEMPwb.Sheets(1).Cells(1,j)=Arr(1,j)
- TEMPwb.Sheets(1).Cells(2,j)=Arr(i,j)
- Next
- TEMPwb.Password=d(Arr(i,1))
- TEMPwb.Close True,FinalFilePath.self.Path&"/"&Prefix&"-"&Arr(i,1)&".xlsx"
- Next
- Msgbox "已完成文件加密"
- EAPP.Quit
复制代码只需要源表和密码表就可以,第2步也让程序自动处理了。复制代码到记事本,另存为.vbs的文件后双击运行即可。
加密成绩单.zip
(746 Bytes, 下载次数: 31)
|
|