複数項目を各項目ごとに7z圧縮する

概要

• ドラッグされた複数項目を7-zipを利用して、各項目ごとに圧縮する

使い方

• vbsファイルに圧縮したい複数の項目をドラッグする。送る(shell:sendto）などに配置してもよい

ソース

日時なし

複数項目を圧縮.vbs

Call CompressListFile

Sub CompressListFile
	Dim fso
	Set fso = CreateObject("Scripting.FileSystemObject")

	Dim WshShell
	set WshShell = WScript.CreateObject("WScript.Shell")
	
	Dim scriptPath
	scriptPath = Replace(WScript.ScriptFullName,WScript.ScriptName,"")

	Dim ts
	Dim compressFileOrFolderName
	Dim archiveFileName

	Dim oParam
	Set oParam = WScript.Arguments

	Dim i
	For i = 0 to oParam.Count - 1
		compressFileOrFolderName = oParam(i)
		If compressFileOrFolderName <> "" then
			If Left(compressFileOrFolderName, 1) = """" then
				compressFileOrFolderName = Mid(compressFileOrFolderName, 2)
			End If
			If right(compressFileOrFolderName, 1) = """" then
				compressFileOrFolderName = Mid(compressFileOrFolderName,1,Len(compressFileOrFolderName) - 1)
			End If

			If fso.FileExists(compressFileOrFolderName) then
				Dim f
				Set f = fso.GetFile(compressFileOrFolderName)

				archiveFileName = f.ParentFolder.Path & "\" & fso.GetBaseName(compressFileOrFolderName)
			Else
				Dim d
				Set d = fso.GetFolder(compressFileOrFolderName)
				
				archiveFileName = d.Path
			End If
			
			Dim cmdline
			cmdline = """C:\Program Files\7-Zip\7z.exe"" a """ & archiveFileName  & ".7z"" """ & compressFileOrFolderName  & """"
			Call WshShell.Run(cmdline, 1, True)
		End if
	Next
	
End Sub

日時付き

複数項目を圧縮（日時あり）.vbs

Call CompressListFile

Sub CompressListFile
	Dim fso
	Set fso = CreateObject("Scripting.FileSystemObject")

	Dim WshShell
	Set WshShell = WScript.CreateObject("WScript.Shell")
	
	Dim scriptPath
	scriptPath = Replace(WScript.ScriptFullName, WScript.ScriptName,"")

	Dim ts
	Dim compressFileOrFolderName

	Dim baseNitiziName
	baseNitiziName = FormatDateTime(now, vbLongDate) & Replace(FormatDateTime(now, vbShortTime), ":", "時") & "分"

	Dim archiveFileName

	Dim oParam
	Set oParam = WScript.Arguments
	Dim i
	Dim base

	For i = 0 to oParam.Count - 1
		compressFileOrFolderName = oParam(i)
		If compressFileOrFolderName <> "" then
			If Left(compressFileOrFolderName,1) = """" then
				compressFileOrFolderName = mid(compressFileOrFolderName,2)
			End If
			If Right(compressFileOrFolderName,1) = """" then
				compressFileOrFolderName = mid(compressFileOrFolderName,1,len(compressFileOrFolderName)-1)
			End If

			If fso.FileExists(compressFileOrFolderName) then
				Dim f
				Set f = fso.GetFile(compressFileOrFolderName)

				archiveFileName = f.ParentFolder.Path & "\" & baseNitiziName & fso.GetBaseName(compressFileOrFolderName)
			Else
				Dim d
				Set d = fso.GetFolder(compressFileOrFolderName)
				archiveFileName = d.ParentFolder.Path & "\" & baseNitiziName & d.Name
			End If
			
			
			Dim cmdline
			cmdline = """C:\Program Files\7-Zip\7z.exe"" a """  & archiveFileName  & ".7z"" """ & compressFileOrFolderName  & """"
			Call WshShell.Run(cmdline,1,true)
		End if
	Next
	
End Sub