[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发帖

[问题求助] VBS为XLS工作表加密保护后不能手动取消?

运行VBS为XLS工作表加了保护密码后,不能手动取消保护工作表?不知道为什么?

没人解决呀?

TOP

用记事本打开 “添加保护密码.VBS”
查找
  1. wk.Sheets(mySheet).Protect PassWord=PassWord
复制代码
替换为
  1. wk.Sheets(mySheet).Protect PassWord
复制代码
1

评分人数

    • ww0000: 谢谢帮助!技术 + 1
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

回复 3# yu2n


    谢谢老师,问题解决,再请教一下,这个脚本如何用于WORD文档?

TOP

回复 4# ww0000

VBS 批量设置 Office Word,Excel 写保护工具.VBS
  1. ' VBS 批量设置 Office Word,Excel 写保护工具
  2. ' 注意:不支持 PowerPoint ,PPT 文档本身无带密码的“写保护”属性
  3. Const sTitle = "VBS 批量设置 Office Word,Excel 写保护工具  By  Yu2n@qq.com"
  4. Call CommandMode(sTitle)
  5. Call Main()
  6. Sub Main()
  7.   'On Error Resume Next
  8.   ' 询问用户操作
  9.   nChoice = Msgbox("请选择:" & vbCrLf & vbCrLf & _
  10.     vbTab & "[ 是(Y) ] 新增写保护密码 (修改密码请先删除后新增)" & vbTab & vbCrLf & vbCrLf & _
  11.     vbTab & "[ 否(N) ] 删除写保护密码" & vbCrLf & vbCrLf & _
  12.     vbTab & "[ 取消  ] 退出程序" & vbCrLf _
  13.     , vbInformation+vbYesNoCancel, sTitle)
  14.   Select Case nChoice
  15.     Case vbYes  :  bProtect = True
  16.     Case vbNo   :  bProtect = False
  17.     Case Else
  18.       WScript.Quit
  19.   End Select
  20.   
  21.   ' 输入文档写保护密码
  22.   sPassword = Inputbox( "> 请输入写保护密码:", sTitle, "" )
  23.   
  24.   ' 选择文件夹
  25.   Dim strFolder, arrPath, strPath, nFileCount, i
  26.   WScript.Echo " --- 请选择 Office Word,Excel 文件路径:"
  27.   strFolder = BrowseForFolder("请选择 Office Word,Excel 文件路径:")
  28.   WScript.Echo strFolder & vbCrLf
  29.   If strFolder = "" Then Exit Sub
  30.   arrPath = ScanFolder(strFolder)
  31.   For Each strPath In arrPath   ' 统计个数,用于显示进度
  32.     If InStr(1, "|.doc|.xls|", Right(strPath,4), vbTextCompare) > 0 Or _
  33.        InStr(1, "|.docx|.xlsx|", Right(strPath,5), vbTextCompare) > 0 Then
  34.       nFileCount = nFileCount + 1
  35.     End If
  36.   Next
  37.   
  38.   ' 执行写保护设置
  39.   Dim dtStart, objWord, objExcel, objPowerPoint
  40.   dtStart = Now()
  41.   WScript.Echo " --- 正在启动 Office Word,Excel ... " & vbCrLf
  42.   Call Word_Init(objWord, objExcel, objPowerPoint)
  43.   For Each strPath In arrPath
  44.     If InStr(1, "|.doc|.xls|", Right(strPath,4), vbTextCompare) > 0 Or _
  45.        InStr(1, "|.docx|.xlsx|", Right(strPath,5), vbTextCompare) > 0 Then
  46.       
  47.       ' 显示进度
  48.       i = i + 1
  49.       strFN = Right(strPath,Len(strPath)-InstrRev(strPath,"\"))
  50.       strMsg = "[成功]"
  51.      
  52.       ' 执行 Office Word,Excel 写保护设置
  53.       If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then _
  54.         If Not WordProtect(objWord, strPath, sPassword, bProtect) Then _
  55.           strMsg = "[失败]"
  56.       If LCase(Right(strPath,4))=".xls" Or LCase(Right(strPath,5))=".xlsx" Then _
  57.         If Not ExcelProtect(objExcel, strPath, sPassword, bProtect) Then _
  58.           strMsg = "[失败]"
  59.       WScript.Echo "[" & i & "/" & nFileCount & "] " & strFN & vbTab & strMsg
  60.     End If
  61.   Next
  62.   
  63.   ' 退出
  64.   WScript.Echo vbCrLf & " --- 正在退出 Office Word,Excel ... " & vbCrLf
  65.   objWord.Quit
  66.   objExcel.Quit
  67.   WScript.Echo " --- 完成。耗时 " & DateDiff("s",dtStart,Now()) & " 秒。" & vbCrLf
  68.   Msgbox "总计 " & nFileCount & " 个文档完成设置,耗时 " & DateDiff("s",dtStart,Now()) & " 秒。", _
  69.     vbInformation+vbOKOnly, sTitle
  70. End Sub
  71. ' 创建 Office Word,Excel对象
  72. Sub Word_Init(ByRef objWord, ByRef objExcel, ByRef objPowerPoint)
  73.   On Error Resume Next
  74.   Const msoAutomationSecurityForceDisable = 3
  75.   Set objWord = CreateObject("Word.Application")
  76.   Set objExcel = CreateObject("Excel.Application")
  77.   If Not Err.Number = 0 Then
  78.     Msgbox "错误:无法创建 Office VBA 对象,请安装 Office Word,Excel ...", _
  79.       vbCritical+vbOKOnly, sTitle
  80.     WScript.Quit(999)
  81.   End If
  82.   If Not objWord.Application.Version >= 12.0 Then
  83.     Msgbox "警告:请使用 Office 2007 以上版本。", vbExclamation+vbOKOnly, sTitle
  84.   End If
  85.   ' 隐藏运行,屏蔽提示
  86.   objWord.Visible = False        :   objWord.DisplayAlerts = False
  87.   objExcel.Visible = False       :   objExcel.DisplayAlerts = False
  88.   ' 禁用以编程方式打开的所有文件中的所有宏,而不显示任何安全警告。
  89.   ' VBA打开文件时(临时)禁用宏 http://club.excelhome.net/thread-1001802-1-1.html
  90.   objWord.AutomationSecurity = msoAutomationSecurityForceDisable
  91.   objExcel.AutomationSecurity = msoAutomationSecurityForceDisable
  92. End Sub
  93. ' 设置 Word 写保护
  94. Function WordProtect(ByRef objWord, ByVal sFilePath, ByVal sPassword, ByVal bProtect)
  95.   On Error Resume Next
  96.   Const wdAllowOnlyReading = 3
  97.   WordProtect = False
  98.   If Not CreateObject("Scripting.Filesystemobject").FileExists(sFilePath) Then Exit Function
  99.   Set objDoc = objWord.Documents.Open(sFilePath)
  100.   If Not objDoc.ProtectionType = wdAllowOnlyReading Then
  101.     If bProtect Then
  102.       Err.Clear   ' 检查是否出错
  103.       objDoc.Protect wdAllowOnlyReading, Ture, CStr(sPassword)
  104.       If Err.Number = 0 Then WordProtect = True
  105.     End If
  106.   Else
  107.     If Not bProtect Then objDoc.Unprotect sPassword
  108.     If Not objDoc.ProtectionType = wdAllowOnlyReading Then WordProtect = True   ' 检查是否生效
  109.   End If
  110.   objDoc.Save
  111.   objDoc.Close False
  112.   'If Not Err.Number = 0 Then WordProtect = True
  113. End Function
  114. ' 设置 Excel 写保护
  115. Function ExcelProtect(ByRef objExcel, ByVal sFilePath, ByVal sPassword, ByVal bProtect)
  116.   On Error Resume Next
  117.   Const wdAllowOnlyReading = 3
  118.   ExcelProtect = False
  119.   If Not CreateObject("Scripting.Filesystemobject").FileExists(sFilePath) Then Exit Function
  120.   Set objWorkbook = objExcel.WorkBooks.Open(sFilePath)
  121.   For Each objWorkSheet In objWorkbook.Worksheets
  122.     If objWorkSheet.ProtectContents = False Then
  123.       If bProtect Then
  124.         Err.Clear   ' 检查是否出错
  125.         objWorkSheet.Protect CStr(sPassword)
  126.         If Err.Number = 0 Then ExcelProtect = True
  127.       End If
  128.     Else
  129.       If Not bProtect Then objWorkSheet.Unprotect CStr(sPassword)
  130.       If objWorkSheet.ProtectContents = False Then ExcelProtect = True   ' 检查是否生效
  131.     End If
  132.   Next
  133.   objWorkbook.Save
  134.   objWorkbook.Close False
  135.   'If Not Err.Number = 0 Then ExcelProtect = True
  136. End Function
  137. ' 浏览文件夹
  138. Function BrowseForFolder(ByVal strTips)
  139.   Dim objFolder
  140.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  141.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
  142. End Function
  143. ' 获取文件夹所有文件夹、文件列表(数组)
  144. Function ScanFolder(ByVal strPath)
  145.     Dim arr() : ReDim Preserve arr(0) : arr(0) = strPath
  146.     Call SCAN_FOLDER(arr, strPath) : ScanFolder = arr
  147. End Function
  148. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
  149.   On Error Resume Next
  150.   Dim fso, objItems, objFile, objFolder
  151.   Set fso = CreateObject("Scripting.FileSystemObject")
  152.   Set objItems = fso.GetFolder(folderSpec)
  153.   If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
  154.   If (Not fso.FolderExists(folderSpec)) Then Exit Function
  155.   For Each objFile In objItems.Files
  156.     ReDim Preserve arr(UBound(arr) + 1)
  157.     arr(UBound(arr)) = objFile.Path
  158.   Next
  159.   For Each objFolder In objItems.subfolders
  160.     ReDim Preserve arr(UBound(arr) + 1)
  161.     arr(UBound(arr)) = objFolder.Path
  162.     Call SCAN_FOLDER(arr, objFolder.Path)
  163.   Next
  164. End Function
  165. ' 以命令提示符环境运行(保留参数)
  166. Sub CommandMode(ByVal sTitle)
  167.   If InStr(1, WScript.FullName, "\cscript.exe", vbTextCompare) > 0 Then Exit Sub
  168.   sCommand = "%Comspec% /c title " & sTitle & " & cscript.exe //NoLogo """ & WScript.ScriptFullName & """"
  169.   For Each oArg In WScript.Arguments
  170.     sArgs = sArgs & " " & """" & oArg & """"
  171.   Next
  172.   CreateObject("WScript.Shell").Run sCommand & sArgs, 1, False
  173.   WScript.Quit
  174. End Sub
复制代码
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

回复 5# yu2n

老师,这个太复杂了,简单一点,我通过其他代码改过来,批量加打开密码,到了Set wk=EAPP.Documents.Open(FSOFile)这一步通不过,请指正!
Const WINDOW_HANDLE = 0
Const OPTIONS = 0
Dim objShell,objFolder,FolderPath,PW,wk,EAPP,FSO,FSOFolder,FSOFile
'获取Excel文件所在文件夹路径
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", OPTIONS,"")
If objFolder Is Nothing Then
        Wscript.Quit
End If
FolderPath =objFolder.Self.Path
PW=Inputbox("请输入密码","批量添加密码")
if len(pw)=0 then Wscript.Quit
Set EAPP=CreateObject("Word.Application")
Set FSO=CreateObject("Scripting.FileSystemObject")
Set FSOFolder=FSO.GetFolder(FolderPath)
For Each FSOFile in FSOFolder.Files
If instr(Fsofile.Name,".doc") then
    Set wk=EAPP.Documents.Open(FSOFile)
wk.PassWord=PW
wk.Close True
End If
EAPP.Quit
Next

TOP

本帖最后由 yu2n 于 2015-1-18 22:06 编辑

回复 6# ww0000
将倒数两行对换:
  1. EAPP.Quit
  2. Next
复制代码
改为
  1. Next
  2. EAPP.Quit
复制代码
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

回复 7# yu2n


    好像要加.Path
  1. Set wk=EAPP.Documents.Open(FSOFile.Path)
复制代码
fso 可以 Set file = fso.openTextFile(FSOFile),不知word 为什么就不行
1

评分人数

    • ww0000: 谢谢帮助!技术 + 1

TOP

本帖最后由 yu2n 于 2015-1-18 22:39 编辑

回复 8# apang

看来明面上的错误就有两个了。

木有办法,楼主嫌代码长,就不做容错了:
  1. Const WINDOW_HANDLE = 0
  2. Const OPTIONS = 0
  3. Dim objShell, objFolder, FolderPath, sPassword, objDoc, objWord, FSO, FSOFolder, oItem
  4. '获取密码
  5. sPassword = Inputbox("请输入密码", "批量添加密码")
  6. If Len(sPassword)=0 Then WScript.Quit
  7. '获取Word文件所在文件夹路径
  8. Set objShell = CreateObject("Shell.Application")
  9. Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", OPTIONS,"")
  10. If objFolder Is Nothing Then WScript.Quit
  11. FolderPath = objFolder.Self.Path
  12. Set objWord = CreateObject("Word.Application")
  13. Set FSO = CreateObject("Scripting.FileSystemObject")
  14. Set FSOFolder = FSO.GetFolder(FolderPath)
  15. For Each oItem in FSOFolder.Files
  16.   If InStr(1, "|doc|docx|", "|" & fso.GetExtensionName(oItem) & "|", vbTextCompare) Then
  17.     Set objDoc = objWord.Documents.Open(oItem.Path)
  18.     objDoc.PassWord = sPassword
  19.     objDoc.Close True
  20.   End If
  21. Next
  22. objWord.Quit
复制代码
1

评分人数

『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

回复 7# yu2n


    谢谢老师,可以了,但不知道为什么,在给EXCEL为密时,wk=EAPP.Workbooks.Open(FSOFile)不用加“.Path”,也不用  EAPP.Quit 和 Next 换位置,都可以成功。为什么在操作WORD时要这样?

TOP

回复 8# apang


        谢谢老师,可以了,但不知道为什么,在给EXCEL为密时,wk=EAPP.Workbooks.Open(FSOFile)不用加“.Path”,也不用  EAPP.Quit 和 Next 换位置,都可以成功。为什么在操作WORD时要这样?

TOP

返回列表