| タイトル | ： Re^9: VB.netによる圧縮 |
| 記事No | ： 2051 |
| 投稿日 | ： 2005/08/31(Wed) 10:26 |
| 投稿者 | ： ageha |
[OSのVer]：Windows [VBのVer]：VB.NET
またお世話になります。
ソース貼り付けます。↓
VB.NET(VS2003-windows2000)
Private Sub Form1_DragDrop(ByVal sender As Object, ByVal e As
System.Windows.Forms.DragEventArgs) Handles MyBase.DragDrop
Dim f2 As New Example
f2.ShowDialog(Me)
'D&Dされたのがフォルダかファイルかを調べるメソッド
For Each FileName As String In CType(e.Data.GetData(DataFormats.FileDrop, True),
String())
If (GetAttr(FileName) And FileAttribute.Directory) = FileAttribute.Directory Then
Call CompDir(Me.Handle.ToInt32, FileName, "C:\7zip.7z")
ElseIf SevenZipCheckArchive(FileName, 1) = 0 Then
Call CompFile(FileName)
End If
Next
End Sub
Private Sub Form1_DragEnter(ByVal sender As Object, ByVal e As
System.Windows.Forms.DragEventArgs) Handles MyBase.DragEnter
If e.Data.GetDataPresent(DataFormats.FileDrop, True) Then
'「ファイル」のドロップを許可
e.Effect = DragDropEffects.Copy
Else
'「ファイル以外」のドロップを禁止
e.Effect = DragDropEffects.None
End If
End Sub
'ディレクトリ処理
Public Function CompDir(ByVal hWnd As Long, ByVal strTargetDir As String, ByVal
strTargetZip As String) As Long
Dim strCommand As String
Dim strOut As String
Dim nSize As Long
Dim sevenZipOpt As String
strOut = Space(512)
nSize = 512
If Dir(strTargetDir, FileAttribute.Normal) <> "" Then
'上書き確認処理
MsgBox(strTargetDir & "すでに存在しています。" & vbCrLf & &
quot;ファイルを上書きします
か？" & vbCrLf & "(はいで上書き,いいえで圧縮中止)", MsgBoxStyle.YesNo
+
MsgBoxStyle.Information, "上書き確認")
End If
sevenZipOpt = "-t7z -m0=LZMA "
strCommand = "a -r " & sevenZipOpt & Chr(34) & strTargetZip &am
p; Chr(34) & " " & Chr(34)
& strTargetDir & "\" & Chr(34) & " *.*"
CompDir = SevenZip(hWnd, strCommand, strOut, nSize)
If CompDir <> 0 Then
'失敗メッセージ
MsgBox("圧縮に失敗しました。")
Else
MsgBox("圧縮成功しました。")
End If
End Function
一部抜粋するとこんな感じです。今は新しく作り直しましたが、未だに現象が続きます。
よろしく願います。
|