今更7-zipのコマンドラインのVBScript

毎回悩むので一応作りました。
7zipのvbsはいろいろパターンがありすぎて混乱するので、自分流を作っておきます。
とりあえず
ファイルをドラッグアンドドロップすると、そのファイル名のパスワードつきzipを元あったファイルのフォルダに作成するというパターンです。
また、圧縮するファイルを一つ一つ明示します。
msgbox objFile.Name　がそれです。
いらないときは削除してください。
　例えば、c:\test\hoge.txt をc:\test\hoge.zipにします
　ただし拡張子ini,dbなどのシステムファイル、accdbのアクセスファイルを除外します。またフルパスが260字以上、使ってはいけない拡張子を除外します。
　さらに丸付き数字、全角アポストロフを置換したファイル名にします。
　もちろんこれは十分ではありませんが。
正規表現は http://dobon.net/vb/dotnet/file/invalidpathchars.html
を参考にしました。
　なお、テストを兼ねてファイル名に凶子が含まれれば、京固に変換します。その前の全角アポストロフを半角アンダーバーに変えているところがわかりにくいので視認性を確保しています。それと機種依存文字の変換はそれ自体の実験が危険な面もあるためです。
なお、パスワードは-pPassword で決まっています。testにしたければ
-ptest にします。かならず後ろに半角スペースをいれてください
　それにしてもパスワードつきzipを作るのに人生にはなんと障害の多いことでしょうか。
これにさらに、
　260字以上の短縮
　日付の保持機能
　などを付け加えないと完全ではないのです。非常に圧縮は奥深いものがあります。
※objWsh.Run は同期処理が良いとのことでTrueに変えました。
http://winofsql.jp/VA003334/infoboard.php?mid=vbsguide&id=051215192026&pid=1

Windows 7以降の64bitからの環境変数で条件分岐(2021/04/15追加)

Windows7で64bitと32bitバージョンができたとき、%ProgramW6432%ができました。
そして、ExpandEnvironmentStringsはそれ以前のバージョンでは空文字ではなく%ProgramW6432%を展開せずそのまま返します。
これを利用して、WindowsのOSのバージョンを判定し、後方五感を確保して、確実にC:\Program Files\7-zip\のフォルダを狙うようにしました。

7zP.vbs、

	Option Explicit
	Dim objArgs, I , strFile, strFolder
	Dim objFile, objFolder,objPath,strScr
	Dim strBase,strExt,strParent,strPath,strZip,RetVal
	Dim objShell : Set objShell = Createobject("WScript.Shell")
	Dim FSO : Set FSO = Createobject("Scripting.FileSystemObject")
        Const cnsPassWord = "Password" '2019/01/08追加
	Set objArgs = Wscript.Arguments
	For I = 0 to objArgs.Count-1
	set objFile = FSO.GetFile(cstr(objArgs(I)))
	strParent =  FSO.GetParentFolderName(objFile)
	set objPath = FSO.GetFolder(strParent)
	strBase = FSO.GetBaseName(cstr(objArgs(I)))
	strExt = FSO.GetExtensionName(cstr(objArgs(I)))
	msgbox objFile.Name ' Delete?
	if fnblExtCheck(strExt) = False then
	If len(objFile.Path & "\" &  objFile.Name) < 260 Then
	 If strExt <> "db" or strExt <> "ini" or strExt <> "accdb" then 'Exclude System File or Access file
	   strPath = strParent & "\"
	   'strZip = strPath & fnstr(strBase) & ".zip" 'Set Zip File Name 'Already File then Do Nothing
        strZip = strPath & fnstr(strBase) & "_" & strExt & ".zip" 'Set Zip File Name 'Already File then Do Nothing
	     if FSO.FileExists(strZip) = False then 
' 2021/04/14 Windows 7以降%Programfiles%は必ずしもC:\Program Files\を指さない
' XP 2003 VISTA等では%ProgramW6432%は使えない
' またWindows 7以降でないと%ProgramW6432%は%ProgramW6432%となる。これを利用して条件を分岐させる。
          IF CreateObject("Wscript.shell").ExpandEnvironmentStrings("%ProgramW6432%") <> "%ProgramW6432%" Then 
          strScr = """%ProgramW6432%" & "\7-zip\7z.exe "" a -p" & cnsPassWord & " " & chr(34) & strZip & chr(34) & " " & chr(34) & strPath & objFile.Name & chr(34)
           Else
           strScr = """%ProgramFiles%" & "\7-zip\7z.exe "" a -p" & cnsPassWord & " " & chr(34) & strZip & chr(34) & " " & chr(34) & strPath & objFile.Name & chr(34)
           End If
	      RetVal = objShell.Run(strScr,0,True)
	     End if
	 End if
	End If
	End If
	Next
	set objShell = Nothing
	set FSO = Nothing
	Wscript.Quit

Function fnStr(strBase)
Dim A1,B1,i,buf
A1=Split("①,②,③,④,’,',凶子",",")
B1=Split("1,2,3,4,_,_,京固",",")
buf=""
buf=strBase
for i= LBound(a1) to UBound(a1)
buf = Replace(buf,cstr(a1(i)),cstr(b1(i)),1,-1)
Next
fnstr=buf
End Function

Function fnblExtCheck(strExt)
Dim Re : Set Re = New RegExp
With Re
 .Pattern = "^(CON|PRN|AUX|NUL|COM[0-9]|LPT[0-9]|CLOCK\$)"
 .Ignorecase = True
 if .test(strExt) = true then 
  fnblExtCheck = true
  Else
  fnblExtCheck = False
  End If
End With
set Re = Nothing
End Function

#VBS/VBScriptで7zipで解凍する場合
ファイル単位で圧縮されている場合のzipファイルを解凍します。
注意：
このVBScriptはファイルを圧縮しているzipファイルを前提としています。フォルダではありません。
7z.exeの場所は以下のところを前提にしています。上記の圧縮ファイルも同様です。
"C:\Program Files\7-Zip\7z.exe"
zipファイルをドラッグアンドドロップすることによってzipファイルのある場所に解凍します。同名のファイルがあれば確認なしで上書きします。同名のファイルがあれば解凍してほしくない場合には-aoaを-aosに変えてください。

ExtractWith7zip.vbs

Option Explicit
Dim objArgs, I , strFile, strFolder
Dim objFile, objFolder,objPath,strScr
Dim strBase,strExt,strParent,strPath,strZip,RetVal
Dim objWSH : Set objWSH = CreateObject("WScript.Shell")
Dim FSO : Set FSO = Createobject("Scripting.FileSystemObject")
Const cnsPassWord = "Password"
Set objArgs = WScript.Arguments
For I = 0 to objArgs.Count-1
With FSO
IF .fileexists(.GetFile(cstr(objArgs(I)))) Then
set objFile = .GetFile(cstr(objArgs(I)))
strParent = .GetParentFolderName(objFile)
set objPath = .GetFolder(strParent)
strBase = .GetBaseName(cstr(objArgs(I)))
strExt = .GetExtensionName(cstr(objArgs(I)))
'msgbox objFile.Name ' Delete?
If strExt = "zip" then
If CreateObject("Wscript.shell").ExpandEnvironmentStrings("%ProgramW6432%") <> "%ProgramW6432%" Then 
strScr = """%ProgramW6432%" & "\7-zip\7z.exe "" x -y -p" & cnsPassWord & " " & chr(34) & objFile.Path & chr(34) & " -o" & chr(34) & strParent & chr(34) & " -aoa"
Else
strScr = """%Programfiles%" & "\7-zip\7z.exe "" x -y -p" & cnsPassWord & " " & chr(34) & objFile.Path & chr(34) & " -o" & chr(34) & strParent & chr(34) & " -aoa"
End If
'WScript.echo strScr
RetVal = objWSH.Run(strScr,0,True)
  If Retval <> 0 then 
   MsgBox "RetVal = " & RetVal & " Error occur End "  & vbCrlf & _ 
  "FileName :"  & objFile.Path & vbCrlf & _ 
  "CommandString :"  & strScr  & vbCrlf & _ 
  "1 Warning (Non fatal error(s)). For example, one or more files were locked by some other application, so they were not compressed. "  & vbCrlf & _ 
  "2 Fatal error "  & vbCrlf & _ 
  "7 Command line error "  & vbCrlf & _ 
  "8 Not enough memory for operation "  & vbCrlf & _ 
  "255 User stopped the process "
   Wscript.Quit
  End If
End If
End If
End With
Next
set objWSH = Nothing
set FSO = Nothing
Wscript.Echo "Finish: RetVal =" & RetVal & vbCrLf & " 0 means Success"
Wscript.Quit

##変更
2019/01/08
Passwordを定数化
Zipのファイル名に拡張子がついていなかったので追加。
2021/04/12
環境変数%ProgramFiles%は時としてC:Program FIles(x86)を参照する場合があるため、%ProgramW6432%に変更。