زیپ کردن فولدر

[Veteran]

سلام دوستان

عزیزان ایا امکانش هست یک فولدر رو در vb بدون کامپوننت به حالت زیپ دراورد و اون فولدر رو زیپ کرد؟
مثلا با api
امکانش هست ؟
یکجایی یکی از دوستان با api این کارو کرده بود اما هرچی میگردم پیدا نمیکنم !
تشکر

[setroyd]

بله سورسش هست باید بگردید ولی خیلی کار باهاش سنگینه .

[Veteran]

بله سورسش هست باید بگردید ولی خیلی کار باهاش سنگینه .
هرچی میگردم فایده نداره
شما نداری کدشو ؟

[Veteran]

این رو پیدا کردم
دوستان تست کنن لطفا اگر کار کرد طرز کارش رو هم به ما بگن
تشکر

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Zip_Activity(Action As String, sFileSource As String, sFileDest As String)

'//copies contents of folder to zip file
Dim ShellClass As Shell32.Shell
Dim Filesource As Shell32.Folder
Dim Filedest As Shell32.Folder
Dim Folderitems As Shell32.Folderitems

If sFileSource = "" Or sFileDest = "" Then GoTo EH

Select Case UCase$(Action)

Case "ZIPFILE"

If Right$(UCase$(sFileDest), 4) <> ".ZIP" Then
sFileDest = sFileDest & ".ZIP"
End If

If Not Create_Empty_Zip(sFileDest) Then
GoTo EH
End If

Set ShellClass = New Shell32.Shell
Set Filedest = ShellClass.NameSpace(sFileDest)

Call Filedest.CopyHere(sFileSource, 20)

Case "ZIPFOLDER"

If Right$(UCase$(sFileDest), 4) <> ".ZIP" Then
sFileDest = sFileDest & ".ZIP"
End If

If Not Create_Empty_Zip(sFileDest) Then
GoTo EH
End If

'//Copy a folder and its contents into the newly created zip file
Set ShellClass = New Shell32.Shell
Set Filesource = ShellClass.NameSpace(sFileSource)
Set Filedest = ShellClass.NameSpace(sFileDest)
Set Folderitems = Filesource.Items

Call Filedest.CopyHere(Folderitems, 20)

Case "UNZIP"

If Right$(UCase$(sFileSource), 4) <> ".ZIP" Then
sFileSource = sFileSource & ".ZIP"
End If

Set ShellClass = New Shell32.Shell
Set Filesource = ShellClass.NameSpace(sFileSource) '//should be zip file
Set Filedest = ShellClass.NameSpace(sFileDest) '//should be directory
Set Folderitems = Filesource.Items '//copy zipped items to directory

Call Filedest.CopyHere(Folderitems, 20)

Case Else

End Select

'//Ziping a file using the Windows Shell API creates another thread where the zipping is executed.
'//This means that it is possible that this console app would end before the zipping thread
'//starts to execute which would cause the zip to never occur and you will end up with just
'//an empty zip file. So wait a second and give the zipping thread time to get started.

Call Sleep(1000)

EH:

If Err.Number <> 0 Then
MsgBox Err.Description, vbExclamation, "error"
End If

Set ShellClass = Nothing
Set Filesource = Nothing
Set Filedest = Nothing
Set Folderitems = Nothing

End Sub

Private Function Create_Empty_Zip(sFileName As String) As Boolean

Dim EmptyZip() As Byte
Dim J As Integer

On Error GoTo EH
Create_Empty_Zip = False

'//create zip header
ReDim EmptyZip(1 To 22)

EmptyZip(1) = 80
EmptyZip(2) = 75
EmptyZip(3) = 5
EmptyZip(4) = 6

For J = 5 To UBound(EmptyZip)
EmptyZip(J) = 0
Next

'//create empty zip file with header
Open sFileName For Binary Access Write As #1

For J = LBound(EmptyZip) To UBound(EmptyZip)
Put #1, , EmptyZip(J)
Next

Close #1

Create_Empty_Zip = True

EH:

If Err.Number <> 0 Then
MsgBox Err.Description, vbExclamation, "Error"
End If

End Function

مشکل حل شد.
اینم اموزش برای دوستانی که ممکنه این مشکل رو داشته باشن و بخوان بدون ocx فایل هارو zip کنن

اول برین توی
references
بعد این رو پیدا و تیک رو بزنید
microsoft shell controls and automation
اوکی کنید

استفاده "
Zip_Activity

Action: نوع عملیات:
=====================
ZIPFILE : زیپ کردن فایل
=================
ZIPFOLDER : زیپ کردن فولدر
==============
UNZIP : استخراح فایل دز فایل zip
============
مثال :
Call Zip_Activity("مسیر ذخیره فایل زیپی که حاوی پرونده ها هست", "مسیر فولدر و یا فایلی که قصد دارید زیپ کنید", "عملیات")
Call Zip_Activity("zipfolder", "C:\pic", "c:\piczip")

===========
توضیح :
عکس های درون فولدر pic در درایو c فشرده سازی مشن در فایل زیپی به نام piczip در درایو c