VBAでZIP圧縮する。
VBScriptからVBAに焼き直し。
Option Explicit
Sub MakeZIP(ZIPfile As String, ParamArray Files() As Variant)
Dim fso As Object
Dim Shell As Object
Dim zFolder As Object
Dim Path As Variant
Dim FileName As String
Dim sFolderItem As Object
Dim zFolderItem As Object
Dim Count As Long
Dim Ans As Long
Set fso = CreateObject("Scripting.FileSystemObject")
If UCase(fso.GetExtensionName(ZIPfile)) <> "ZIP" Then
MsgBox "Invalid Extension Name - " & ZIPfile, vbCritical
Exit Sub
End If
If Not fso.FileExists(ZIPfile) Then
fso.CreateTextFile(ZIPfile, False).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
End If
Set Shell = CreateObject("Shell.Application")
Set zFolder = Shell.Namespace(fso.GetAbsolutePathName(ZIPfile))
For Each Path In Files
FileName = fso.GetFileName(Path)
Set sFolderItem = Shell.NameSpace(fso.GetParentFolderName(fso.GetAbsolutePathName(Path))).ParseName(FileName)
If sFolderItem Is Nothing Then
MsgBox Path & " - Not Found.", vbCritical
Exit For
End If
Do
Set zFolderItem = zFolder.ParseName(FileName)
If zFolderItem Is Nothing Then
Count = zFolder.Items().Count
zFolder.CopyHere sFolderItem
Do While zFolder.Items().Count =< Count
Application.Wait Now + TimeSerial(0, 0, 1)
Loop
Exit Do
Else
Ans = MsgBox("このフォルダには既に次のファイルが存在します:" & vbLf & vbLf & _
"""" & FileName & """" & vbLf & vbLf & "既存のファイルと置き換えますか?", _
vbYesNoCancel + vbQuestion, "ファイル置換の確認")
Select Case Ans
Case vbYes
zFolderItem.InvokeVerb ("delete")
Case vbNo
Exit Do
Case vbCancel
Exit For
End Select
End If
Loop
Next
End Sub
« VB.NETからAdobe ReaderでPDFファイルを印刷する。(その2) | トップページ | VB.NETでZIP圧縮コマンドを作る。 »