Excel 參照路徑批次修改

多年前為了一些人用了 Excel 的參照功能
但因為需要更換 File Server 路徑導致參照會失效
因此撰寫了 VBScript 來進行置換

多年後翻出此程式碼
不確定是否有 Bug, 也許還能用也說不定

===== 程式開始 =====

' 程式會自動搜尋所在資料夾與子資料夾中所有 .xls 檔案並進行字串取代
' 本程式要是 ANSI 編碼

ReplaceCount=10
Dim FindString(10)
Dim ReplaceString(10)
FindString(0)="\\FileServer-01\ShareFolder-01"
FindString(1)="\\FileServer-01\ShareFolder-02"
FindString(2)="\\FileServer-01\ShareFolder-03"
FindString(3)="\\FileServer-01\ShareFolder-04"
FindString(4)="\\FileServer-01\ShareFolder-05"
FindString(5)="\\FileServer-01\ShareFolder-06"
FindString(6)="\\FileServer-01\ShareFolder-07"
FindString(7)="\\FileServer-01\ShareFolder-08"
FindString(8)="\\FileServer-01\ShareFolder-09"
FindString(9)="\\FileServer-01\ShareFolder-10"
ReplaceString(0)="\\FileServer-02\ShareFolder-01"
ReplaceString(1)="\\FileServer-02\ShareFolder-02"
ReplaceString(2)="\\FileServer-02\ShareFolder-03"
ReplaceString(3)="\\FileServer-02\ShareFolder-04"
ReplaceString(4)="\\FileServer-02\ShareFolder-05"
ReplaceString(5)="\\FileServer-02\ShareFolder-06"
ReplaceString(6)="\\FileServer-02\ShareFolder-07"
ReplaceString(7)="\\FileServer-02\ShareFolder-08"
ReplaceString(8)="\\FileServer-02\ShareFolder-09"
ReplaceString(9)="\\FileServer-02\ShareFolder-10"

OpenExcelPassword=inputbox("如果開啟 Excel 檔案需要密碼, 請輸入密碼, 若不須密碼請直接按確認")

Dim TargetPath
Dim FilesArray()
'-----------------------------------------------------------------------

NowPath=left(Wscript.ScriptFullName,len(Wscript.ScriptFullName)-len(Wscript.ScriptName))

 ' 啟用檔案處理元件
  Set fso=CreateObject("Scripting.FileSystemObject")
  Set objExcel = CreateObject("Excel.Application")
  objExcel.Visible = False
  objExcel.DisplayAlerts = False
  objExcel.ScreenUpdating = False
  

  Dim BypassArray()
  BypassCount=0
  
  Dim ErrorArray()
  ErrorCount=0
  
 For Each TargetPath In Wscript.Arguments
  TargetLogFile=replace(TargetPath,"\","_")&".log"
  Set fid = fso.OpenTextFile(NowPath&TargetLogFile, 8, true, -1)
  

    Dim AlreadyArray()
    AlreadyCount=0
    Set fidAlready = fso.OpenTextFile(NowPath&TargetLogFile, 1, false, -1)
    While Not fidAlready.AtEndOfStream
     FileProcess=fidAlready.readline
     if InStr(FileProcess," File: ") > 0 then
      AlreadyCount=AlreadyCount+1
     end if
    Wend
    AlreadyCount=AlreadyCount-1
    fidAlready.close
    ReDim AlreadyArray(AlreadyCount)
    AlreadyCount=0
    Set fidAlready = fso.OpenTextFile(NowPath&TargetLogFile, 1, false, -1)
    While Not fidAlready.AtEndOfStream
     FileProcess=fidAlready.readline
     if InStr(FileProcess," File: ") > 0 then
      FileProcessSplit=split(FileProcess," File: ")
      AlreadyArray(AlreadyCount)=FileProcessSplit(1)
      AlreadyCount=AlreadyCount+1
     end if
    Wend
    AlreadyCount=AlreadyCount-1
    fidAlready.close
  
  LoopFolder(TargetPath)
  fid.Close
  wscript.echo "Finish!! "&TargetPath
 Next
  
 Function LoopFolder(Target)
  TargetIsFolder=0
  if fso.FolderExists(Target) then
   TargetIsFolder=1
   set folder=fso.GetFolder(Target)
   For Each subFolder in folder.SubFolders
    ' 進入 SubFolder
    Enter=1
    if instr(subFolder,"Folder\To\Bypass") then
     Enter=0
    end if
    if Enter=1 then
     LoopFolder(subFolder)
    end if
   Next
   ' 沒進 SubFolder
    FilesCount=0
    For Each File In folder.Files
     FilesCount=FilesCount+1
     ReDim Preserve FilesArray(FilesCount)
     FilesArray(FilesCount-1)=File
    Next
  else
   FilesCount=0
   FilesCount=FilesCount+1
   ReDim Preserve FilesArray(FilesCount)
   FilesArray(FilesCount-1)=Target
  end if
   
   for i=0 to FilesCount-1
    if fso.GetExtensionName(FilesArray(i))="xls" or fso.GetExtensionName(FilesArray(i))="xlsx" then
     Skip=0
     if Skip=0 then
      for j=0 to AlreadyCount
       if InStr(FilesArray(i),AlreadyArray(j)) then
        Skip=1
        exit for
       end if
      next
     end if
     if Skip=0 then
      fid.writeline Date&" "&Time&" Process!!       "&FilesArray(i)
      DoReplaceSTR=ReplaceSTR(FilesArray(i))
     end if
    end if
   next
 End Function
 
 Function ReplaceSTR(TargetFile)
  'wscript.echo "Staring String Replace of [" & TargetFile & "]"
  On Error Resume Next
  Set objWorkbook = objExcel.Workbooks.Open (TargetFile, false, false, , OpenExcelPassword)
  objExcel.ScreenUpdating = False
  If Err.Number <> 0 Then
   ErrDesc=Err.Description
   ErrNumber=Err.Number
   fid.writeline Date&" "&Time&" Error!!!! File: "&TargetFile&" ---------- "&ErrNumber&" "&ErrDesc
   if ErrNumber=462 then
    fid.Close
    wscript.echo TargetPath
    wscript.quit
   end if
  else
   Found=0
   For Each S in objWorkbook.WorkSheets
    S.Activate
    for i=0 to ReplaceCount
     FocusReplaceSTR=S.Cells.Replace(FindString(i),ReplaceString(i))
    next
   Next

   objWorkbook.Save
   objWorkbook.Close
   objExcel.Quit
   fid.writeline Date&" "&Time&" Success!! File: "&TargetFile
   'Shell.Run("cmd /C ""del /F /Q "&TargetFile&""""),0,True
  End If
  'wscript.echo "String Replace for [" & TargetFile & "] is Finished"
 End Function

===== 程式結束 =====