wk.Sheets(mySheet).Protect PassWord=PassWord
复制代码

wk.Sheets(mySheet).Protect PassWord
复制代码

' VBS 批量设置 Office Word,Excel 写保护工具
' 注意：不支持 PowerPoint ，PPT 文档本身无带密码的“写保护”属性
Const sTitle = "VBS 批量设置 Office Word,Excel 写保护工具  By  Ｙu２n＠qq.com"
Call CommandMode(sTitle)
Call Main()

Sub Main()
  'On Error Resume Next
  ' 询问用户操作
  nChoice = Msgbox("请选择：" & vbCrLf & vbCrLf & _
    vbTab & "[ 是(Y) ] 新增写保护密码 (修改密码请先删除后新增)" & vbTab & vbCrLf & vbCrLf & _
    vbTab & "[ 否(N) ] 删除写保护密码" & vbCrLf & vbCrLf & _
    vbTab & "[ 取消  ] 退出程序" & vbCrLf _
    , vbInformation+vbYesNoCancel, sTitle)
  Select Case nChoice
    Case vbYes  :  bProtect = True
    Case vbNo   :  bProtect = False
    Case Else
      WScript.Quit
  End Select
  
  ' 输入文档写保护密码
  sPassword = Inputbox( "> 请输入写保护密码：", sTitle, "" )
  
  ' 选择文件夹
  Dim strFolder, arrPath, strPath, nFileCount, i
  WScript.Echo " --- 请选择 Office Word,Excel 文件路径："
  strFolder = BrowseForFolder("请选择 Office Word,Excel 文件路径：")
  WScript.Echo strFolder & vbCrLf
  If strFolder = "" Then Exit Sub
  arrPath = ScanFolder(strFolder)
  For Each strPath In arrPath   ' 统计个数，用于显示进度
    If InStr(1, "|.doc|.xls|", Right(strPath,4), vbTextCompare) > 0 Or _
       InStr(1, "|.docx|.xlsx|", Right(strPath,5), vbTextCompare) > 0 Then
      nFileCount = nFileCount + 1
    End If
  Next
  
  ' 执行写保护设置
  Dim dtStart, objWord, objExcel, objPowerPoint
  dtStart = Now()
  WScript.Echo " --- 正在启动 Office Word,Excel ... " & vbCrLf
  Call Word_Init(objWord, objExcel, objPowerPoint)
  For Each strPath In arrPath
    If InStr(1, "|.doc|.xls|", Right(strPath,4), vbTextCompare) > 0 Or _
       InStr(1, "|.docx|.xlsx|", Right(strPath,5), vbTextCompare) > 0 Then
       
      ' 显示进度
      i = i + 1
      strFN = Right(strPath,Len(strPath)-InstrRev(strPath,"\"))
      strMsg = "[成功]"
     
      ' 执行 Office Word,Excel 写保护设置
      If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then _
        If Not WordProtect(objWord, strPath, sPassword, bProtect) Then _
          strMsg = "[失败]"
      If LCase(Right(strPath,4))=".xls" Or LCase(Right(strPath,5))=".xlsx" Then _
        If Not ExcelProtect(objExcel, strPath, sPassword, bProtect) Then _
          strMsg = "[失败]"

      WScript.Echo "[" & i & "/" & nFileCount & "] " & strFN & vbTab & strMsg
    End If
  Next
  
  ' 退出
  WScript.Echo vbCrLf & " --- 正在退出 Office Word,Excel ... " & vbCrLf
  objWord.Quit
  objExcel.Quit
  WScript.Echo " --- 完成。耗时 " & DateDiff("s",dtStart,Now()) & " 秒。" & vbCrLf
  Msgbox "总计 " & nFileCount & " 个文档完成设置，耗时 " & DateDiff("s",dtStart,Now()) & " 秒。", _
    vbInformation+vbOKOnly, sTitle
End Sub


' 创建 Office Word,Excel对象
Sub Word_Init(ByRef objWord, ByRef objExcel, ByRef objPowerPoint)
  On Error Resume Next
  Const msoAutomationSecurityForceDisable = 3
  Set objWord = CreateObject("Word.Application")
  Set objExcel = CreateObject("Excel.Application")
  If Not Err.Number = 0 Then
    Msgbox "错误：无法创建 Office VBA 对象，请安装 Office Word,Excel ...", _
      vbCritical+vbOKOnly, sTitle
    WScript.Quit(999)
  End If
  If Not objWord.Application.Version >= 12.0 Then
    Msgbox "警告：请使用 Office 2007 以上版本。", vbExclamation+vbOKOnly, sTitle
  End If
  ' 隐藏运行，屏蔽提示
  objWord.Visible = False        :   objWord.DisplayAlerts = False
  objExcel.Visible = False       :   objExcel.DisplayAlerts = False
  ' 禁用以编程方式打开的所有文件中的所有宏，而不显示任何安全警告。
  ' VBA打开文件时（临时）禁用宏 http://club.excelhome.net/thread-1001802-1-1.html
  objWord.AutomationSecurity = msoAutomationSecurityForceDisable
  objExcel.AutomationSecurity = msoAutomationSecurityForceDisable
End Sub

' 设置 Word 写保护
Function WordProtect(ByRef objWord, ByVal sFilePath, ByVal sPassword, ByVal bProtect)
  On Error Resume Next
  Const wdAllowOnlyReading = 3
  WordProtect = False
  If Not CreateObject("Scripting.Filesystemobject").FileExists(sFilePath) Then Exit Function
  Set objDoc = objWord.Documents.Open(sFilePath)
  If Not objDoc.ProtectionType = wdAllowOnlyReading Then
    If bProtect Then
      Err.Clear   ' 检查是否出错
      objDoc.Protect wdAllowOnlyReading, Ture, CStr(sPassword)
      If Err.Number = 0 Then WordProtect = True
    End If
  Else
    If Not bProtect Then objDoc.Unprotect sPassword
    If Not objDoc.ProtectionType = wdAllowOnlyReading Then WordProtect = True   ' 检查是否生效
  End If
  objDoc.Save
  objDoc.Close False
  'If Not Err.Number = 0 Then WordProtect = True
End Function

' 设置 Excel 写保护
Function ExcelProtect(ByRef objExcel, ByVal sFilePath, ByVal sPassword, ByVal bProtect)
  On Error Resume Next
  Const wdAllowOnlyReading = 3
  ExcelProtect = False
  If Not CreateObject("Scripting.Filesystemobject").FileExists(sFilePath) Then Exit Function
  Set objWorkbook = objExcel.WorkBooks.Open(sFilePath)
  For Each objWorkSheet In objWorkbook.Worksheets
    If objWorkSheet.ProtectContents = False Then
      If bProtect Then
        Err.Clear   ' 检查是否出错
        objWorkSheet.Protect CStr(sPassword)
        If Err.Number = 0 Then ExcelProtect = True
      End If
    Else
      If Not bProtect Then objWorkSheet.Unprotect CStr(sPassword)
      If objWorkSheet.ProtectContents = False Then ExcelProtect = True   ' 检查是否生效
    End If
  Next
  objWorkbook.Save
  objWorkbook.Close False
  'If Not Err.Number = 0 Then ExcelProtect = True
End Function

' 浏览文件夹
Function BrowseForFolder(ByVal strTips)
  Dim objFolder
  Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
End Function

' 获取文件夹所有文件夹、文件列表(数组)
Function ScanFolder(ByVal strPath)
    Dim arr() : ReDim Preserve arr(0) : arr(0) = strPath
    Call SCAN_FOLDER(arr, strPath) : ScanFolder = arr
End Function
Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
  On Error Resume Next
  Dim fso, objItems, objFile, objFolder
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set objItems = fso.GetFolder(folderSpec)
  If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
  If (Not fso.FolderExists(folderSpec)) Then Exit Function
  For Each objFile In objItems.Files
    ReDim Preserve arr(UBound(arr) + 1)
    arr(UBound(arr)) = objFile.Path
  Next
  For Each objFolder In objItems.subfolders
    ReDim Preserve arr(UBound(arr) + 1)
    arr(UBound(arr)) = objFolder.Path
    Call SCAN_FOLDER(arr, objFolder.Path)
  Next
End Function

' 以命令提示符环境运行(保留参数)
Sub CommandMode(ByVal sTitle)
  If InStr(1, WScript.FullName, "\cscript.exe", vbTextCompare) > 0 Then Exit Sub
  sCommand = "%Comspec% /c title " & sTitle & " & cscript.exe //NoLogo """ & WScript.ScriptFullName & """"
  For Each oArg In WScript.Arguments
    sArgs = sArgs & " " & """" & oArg & """"
  Next
  CreateObject("WScript.Shell").Run sCommand & sArgs, 1, False
  WScript.Quit
End Sub
复制代码

EAPP.Quit
Next
复制代码

Next
EAPP.Quit
复制代码

Set wk=EAPP.Documents.Open(FSOFile.Path) 
复制代码

Const WINDOW_HANDLE = 0
Const OPTIONS = 0
Dim objShell, objFolder, FolderPath, sPassword, objDoc, objWord, FSO, FSOFolder, oItem
'获取密码
sPassword = Inputbox("请输入密码", "批量添加密码")
If Len(sPassword)=0 Then WScript.Quit
'获取Word文件所在文件夹路径
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", OPTIONS,"")
If objFolder Is Nothing Then WScript.Quit
FolderPath = objFolder.Self.Path
Set objWord = CreateObject("Word.Application")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSO.GetFolder(FolderPath)
For Each oItem in FSOFolder.Files
  If InStr(1, "|doc|docx|", "|" & fso.GetExtensionName(oItem) & "|", vbTextCompare) Then
    Set objDoc = objWord.Documents.Open(oItem.Path)
    objDoc.PassWord = sPassword
    objDoc.Close True
  End If
Next
objWord.Quit
复制代码