VBAで複数のエクセルファイルを自動圧縮

質問

VBAで複数のエクセルファイルを自動圧縮

お世話になります。

以下サイトなどを参考にVBAでエクセルファイルの圧縮をさせようとしています。
ダイアログで圧縮したいファイルを指定して圧縮するところまではできました。
http://oshiete.hmv.co.jp/qa5155002.html

■やりたいこと
特定のフォルダにある複数のファイルを個別に圧縮して、それぞれzipファイルとしたい。
圧縮するファイルを指定するダイアログは出さずに、自動化したい。

■VBAの記述

Dim Filename As String
Dim strArchiveName As String
Dim strCommand As String
Dim RC As Long
Dim hWnd As Long
Dim strOutPut As String * 512
Dim lngSize As Long
Dim strPassWord As String

strPassWord = "pass"

'ハンドル取得
hWnd = FindWindow("XLMANI", Application.Caption)

'★ファイル名取得★
Filename = Application.GetOpenFilename("*.xls(*.xls),*.xls")
If Filename = "False" Then Exit Sub

Filename = Mid$(Filename, InStrRev(Filename, "\") + 1)
strArchiveName = Mid$(Filename, InStrRev(Filename, "\") + 1, InStrRev(Filename, ".") - InStrRev(Filename, "\") - 1) & & ".zip"
strCommand = "-uP " & strPassWord & " " & strArchiveName & " " & Filename
lngSize = Len(strOutPut)

RC = Zip(hWnd, strCommand, strOutPut, lngSize)

■質問

　ファイル名を毎回変えて繰り返し処理すればいいと考えてますが、
　圧縮するファイルを指定するダイアログを消すことができません。。。

　ファイル名を以下のように直接指定しましたが、以下エラーが出てしまいます。
　VBAで取得したファイル名で圧縮するような記述の仕方があればご教示いただけると助かります！

'★ファイル名取得★
Filename = Application.GetOpenFilename("*.xls(*.xls),*.xls")
If Filename = "False" Then Exit Sub

　 ↓以下に変更したがエラー

　Filename = "C:\" & "test.xls" ←とりあえずファイル名を固定で指定したつもり。。

　●イミディエイトに表示されるエラー

　　zip warning: name not matched: test.xls
　　zip warning: test.zip not found or empty

回答No.5

DOUGLAS_ · ベストアンサー

#4 DOUGLAS_ です。
＞Filename = "\\FileSarver1\aaa\test.xls"

#4 の
myPath = "D:\hoge\"
を
myPath = "\\FileSarver1\aaa\"
に
ChDrive Left(myPath, 1)
ChDir myPath
の２行を
CreateObject("WScript.Shell").CurrentDirectory = myPath
に変えてお試しください。

お礼

ご回答ありがとうございます！
大変助かりました！

パスワード部分は以下で出力できましたので
参考までに記載しておきますね。

dim Pass as string

Pass = "hoge"

strCommand = "-uP " & Pass & " " & strArchiveName & " " & Filename

回答No.6

kmetu

> Filename = "\\FileSarver1\aaa\test.xls"

これで指定は問題ありませんが、元のソースではZIPの操作をするのにフォルダの指定がなく、カレントフォルダで操作するようになっているように見受けられます。

ローカルで上手くいったのはカレントのフォルダがC:\だったのでしょう。

ですので、Filename = "\\FileSarver1\aaa\test.xls"の後ろでカレントフォルダを\\FileSarver1\aaaに指定してやる必要があります。

CreateObject("WScript.Shell").CurrentDirectory = "\\FileSarver1\aaa"

の一行を入れてみてください。

蛇足ですが

なんども　"\\FileSarver1\aaa"をタイプするのはタイプミスする可能性がありますし、後でフォルダを変更したい場合、複数の指定箇所を変更しなくてはいけないので面倒です。

m_CurrentDir="\\FileSarver1\aaa"
として
Filename = m_CurrentDir & "\test.xls"
CreateObject("WScript.Shell").CurrentDirectory = m_CurrentDir
のようにしたほうが間違いが少なくなります。

お礼

ご回答ありがとうございます！

とても参考になりました！

ありがとうございました！！

回答No.4

DOUGLAS_

'【４】サンプルコード
Option Explicit
Private Declare Function Zip Lib "Zip32j" (ByVal hWnd As Integer, ByVal szCmdLine As String, ByVal szOutPut As String, ByVal dwsize As Integer) As Integer
Private Declare Function FindWindow Lib "USER32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Sub testZip()
'Zip32 による圧縮
　Dim hWnd As Long
　Dim FSO As Object
　Dim myPath As String
' Dim strPassWord As String
　Dim Filename As String
　Dim strArchiveName As String
　Dim strCommand As String
　Dim strOutPut As String * 512
　Dim lngSize As Long
　Dim RC As Long

'ハンドル取得
　hWnd = FindWindow("XLMANI", Application.Caption)

　Set FSO = CreateObject("Scripting.FileSystemObject")
' strPassWord = "pass"
　myPath = "D:\hoge\"
　ChDrive Left(myPath, 1)
　ChDir myPath

'ファイル名取得
　Filename = Dir(myPath & "*.xls")
　Do While Filename <> ""
　　strArchiveName = """" & FSO.GetBaseName(Filename) & ".zip"""
　　strCommand = "-u " & strArchiveName & " """ & Filename & """"
　　lngSize = Len(strOutPut)
　　RC = Zip(hWnd, strCommand, strOutPut, lngSize)
　　Debug.Print strOutPut
　　Filename = Dir
　Loop
　Set FSO = Nothing
End Sub

お礼

ご回答ありがとうございます！
できました！！
大変たすかりました！！！

回答No.3

DOUGLAS_

#1 DOUGLAS_ です。
＃長くなりましたので、２つに分けて投稿いたします。
　じっくりと、問題を拝見いたしました。

【１】先ず、余談ですが．．．
http://okwave.jp/qa/q5155002.html
#2 さんが書いていらっしゃるように
＞hWnd = FindWindow("XLMANI", Application.Caption)
の "XLMANI" は "XLMAIN" ではないのかなと思って直してみると、
＞実行時エラー '6':
＞オーバーフローしました。
と怒られてしまいます。

　これは、"ZIP32J.DLL" を参照する Declare ステートメント 内での エイリアス？ の型と、Dim ステートメント で宣言している対応する変数の型とが異なっているからかと存じます。
　「Function Zip」の Declare ステートメント 内の「Integer」を全て「Long」に書き換えれば問題なさそうです。
＃ところが、WEBサーフィン してみると、「hWnd は 0 でよい」というような記述もありますので、この辺りはそのままでも問題ないのかなとも存じます。従って、『余談です』と書いた次第ですが、そういう経緯で、下記の サンプルコード でも、この部分はそのままにしました。

【２】さて、本題に入りますが。。。
http://okwave.jp/qa/q2405614.html
#3 さんがお示しの コード を実行してみると、何も問題なく 圧縮ファイル が作成されるのですが、
Filename = ～～
として、直接、ファイル名 を指定すると不具合が発生する『場合もある』ようです。

　Filename = Application.GetOpenFilename( ～～
となっているところが ミソ かなと思って、GetOpenFilename メソッド の ヘルプ を覗いてみました。

　バッチリです！！
＞このメソッドを実行することによって、
＞カレント ドライブやカレント フォルダが変更される可能性があります。
と出ています。これですね！！

　そこで、
ChDrive Left(myPath, 1)
ChDir myPath
で「カレント ドライブやカレント フォルダ」を変更してやると OK でした。

【３】次に
strCommand = "-uP " & strPassWord ～～
の件ですが、先ず、行の最後の「& &」は「&」ですね。
　それはさておき、ダウンロード した ファイル の中から、「ZIP32J.DLL\zip32j\SDK\CMD_ZIP.TXT」を見てみると、
＞-P password　暗号化する。
＞-u　書庫にファイルを追加・更新する。
となっているのですが、どうも、オプションスイッチ の指定の仕方が解りません。
　tochou4848 さんがお書きのように、
strCommand = "-uP " & strPassWord & " " & strArchiveName & " " & Filename
としても、圧縮フォルダ はできますが、中身が空っぽです。

　この件につきましては、随分とあっちこっち WEBサーフィン してみましたが、原因が解りませんので、今回は「-P」オプション 抜きで サンプルコード をお示しいたします。

　なお、「strArchiveName」・「Filename」の双方を ダブルクォーテーション で括った方がよいかと存じまして、そのような コーディング にしております。

お礼

ご回答ありがとうございます！
できました！！
大変たすかりました！！！

回答No.2

kmetu

C:\test.xlsは存在するんですよね。

お礼

ご回答ありがとうございます。

>　C:\test.xlsは存在するんですよね。

はい、ファイルは存在してます。
サンプルデータも登録してます。

補足

大変申し訳ございません。
ファイルネームが違いました。。
ローカルではうまくいきました。

今度は、ネットワーク上のファイルサーバー上のファイルを指定するとうまくいかないので、
指定の方法が間違っているのだと思いますが、以下のように記述していますが、
どこの記述がまずいかおわかりになりますでしょうか？

Filename = "\\FileSarver1\aaa\test.xls"

回答No.1

DOUGLAS_

どうも、ご質問内容がややこしそうですので、
＞特定のフォルダにある複数のファイルを個別に圧縮して、それぞれzipファイルとしたい。
＞圧縮するファイルを指定するダイアログは出さずに、自動化したい。
という部分についてのみ、ヒント を一つお示しいたします。

[Dir 関数] の ヘルプ をご覧ください。

Sub test()
　Dim FSO As Object
　Dim myPath As String
　Dim Filename As String
　Set FSO = CreateObject("Scripting.FileSystemObject")
　myPath = "D:\hoge\*.xls"
'（A）+（B）を取得
　Filename = Dir(myPath)
　Do While Filename <> ""
'（A）「拡張子」を除いた「ファイル名」を取得
　　Debug.Print FSO.GetBaseName(Filename)
'（B）「拡張子」を取得
　　Debug.Print FSO.GetExtensionName(Filename)
'（A）+「".zip"」を取得
　　Debug.Print Left(Filename, Len(Filename) - 4) & ".zip"
'ファイル名 に "xls" が含まれていないことが確かであれば、下記でもOK
　　Debug.Print Replace(Filename, "xls", "zip")
　　Filename = Dir
　Loop
　Set FSO = Nothing
End Sub