-
- Destek
-
-
Özel Arama
![]() |
Sub Zip_Paketi_Cikart()
Dim Komut As String, Islem As Long, Parametre As String
Dim Zip_Dosyasi As String, Hedef_Klasor As String, Win_Zip As String
Win_Zip = "C:\Program Files\WinZip\WINZIP32.EXE"
Zip_Dosyasi = ThisWorkbook.Path & Application.PathSeparator & "DosyaAdi.zip"
Parametre = "-e"
Hedef_Klasor = ThisWorkbook.Path & Application.PathSeparator
DoEvents
Komut = Chr(34) + Win_Zip + Chr(34) + " " + Parametre + " " + Chr(34) + Zip_Dosyasi + Chr(34) + " " + Chr(34) + Hedef_Klasor + Chr(34)
Islem = Shell(Komut, vbNormalFocus)
MsgBox Zip_Dosyasi & " dosyası " & vbCrLf & Hedef_Klasor & " klasörüne çıkartıldı.", vbInformation, "İşlem tamam"
End Sub
Sub Zip_Paketi_Yap()
Dim Komut As String, Islem As Long, Parametre As String
Dim Son_Dosya As String, Ziplenecek_Dosya As String, Win_Zip As String
Win_Zip = "C:\Program Files\WinZip\WINZIP32.EXE"
Son_Dosya = ThisWorkbook.Path & Application.PathSeparator & "Yeni.zip"
Parametre = "-a -en -r"
Ziplenecek_Dosya = ThisWorkbook.Path & Application.PathSeparator & "KlasorAdi\DosyaAdi.gif"
DoEvents
Komut = Chr(34) + Win_Zip + Chr(34) + " " + Parametre + " " + Chr(34) + Son_Dosya + Chr(34) + " " + Chr(34) + Ziplenecek_Dosya + Chr(34)
Islem = Shell(Komut, vbNormalFocus)
MsgBox Ziplenecek_Dosya & vbCrLf & Son_Dosya & vbCrLf & "olarak ziplendi.", vbInformation, "İşlem tamam"
End Sub
Sub Paketten_Cikart()
Dim Win_Rar As String, KaynakDosya As String, HedefKlasor As String
Dim KaynakYol As String, GeciciKaynak As String, GeciciDosya As String, FSO As Object
Win_Rar = "C:\Program Files\WinRAR\WinRar.exe"
Set FSO = CreateObject("Scripting.FilesystemObject")
On Error GoTo hata
KaynakYol = ThisWorkbook.Path & Application.PathSeparator
KaynakDosya = "PSKapat Setup.rar"
HedefKlasor = ThisWorkbook.Path & Application.PathSeparator
If InStr(1, KaynakYol, " ") > 0 Then
GeciciKaynak = "C:\" & Replace(Replace(Replace(KaynakYol, " ", "_"), "\", "_"), ":", "_")
GeciciDosya = Replace(KaynakDosya, " ", "_")
On Error Resume Next
MkDir GeciciKaynak
On Error GoTo 0
FileCopy KaynakYol & KaynakDosya, GeciciKaynak & Application.PathSeparator & GeciciDosya
GeciciDosya = Replace(KaynakDosya, " ", "_")
Shell Win_Rar & " X " & CStr(GeciciKaynak & Application.PathSeparator & GeciciDosya) & " " & CStr(GeciciKaynak)
Do
On Error Resume Next
Kill GeciciKaynak & Application.PathSeparator & GeciciDosya
Loop Until Err.Number <> 70
On Error GoTo 0
Call Klasoru_Kopyala(GeciciKaynak, HedefKlasor)
FSO.DeleteFolder GeciciKaynak, True
Else
If InStr(1, HedefKlasor, " ") > 0 Then
GeciciKaynak = "C:\" & Replace(Replace(Replace(HedefKlasor, " ", "_"), "\", "_"), ":", "_")
On Error Resume Next
MkDir GeciciKaynak
On Error GoTo 0
Shell Win_Rar & " X " & CStr(KaynakYol & Application.PathSeparator & KaynakDosya) & " " & CStr(GeciciKaynak & Application.PathSeparator)
Call Klasoru_Kopyala(GeciciKaynak, HedefKlasor)
FSO.DeleteFolder GeciciKaynak, True
Else:
Shell Win_Rar & " X " & CStr(KaynakYol & Application.PathSeparator & KaynakDosya) & " " & CStr(HedefKlasor)
End If
End If
Set FSO = Nothing
MsgBox "Rar paketi başarıyla çıkartıldı.", vbInformation, "İşlem tamam"
Exit Sub
hata:
MsgBox "Bir hata oluştu.", vbCritical, "İşlem başarısız"
Set FSO = Nothing
End Sub
Sub Klasoru_Kopyala(Kaynak_Klasor As String, Hedef_Klasor As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FilesystemObject")
If Right(Kaynak_Klasor, 1) = "\" Then Kaynak_Klasor = Left(Kaynak_Klasor, Len(Kaynak_Klasor) - 1)
If Right(Hedef_Klasor, 1) = "\" Then Hedef_Klasor = Left(Hedef_Klasor, Len(Hedef_Klasor) - 1)
FSO.CopyFolder Source:=Kaynak_Klasor, Destination:=Hedef_Klasor
Set FSO = Nothing
End Sub
rondebruin yazdı:Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
'If you want to extract only one file you can use this:
'oApp.Namespace(FileNameFolder).CopyHere _
'oApp.Namespace(Fname).items.Item("test.txt")
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub
Muhammet AYTAŞ yazdı: Ama dediğim gibi arkadaş en iyisi senin kodları kendine uyarlasın.
Bülent yazdı:Çeşit sunduk, dilediğini kullansın.
Hem bu kadar çeşitliliği baharatçıda bile bulmak zor.
Bülent yazdı:Muhammet hocam, şöyle bir şey buldum, müsadenizle;rondebruin yazdı:Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
'If you want to extract only one file you can use this:
'oApp.Namespace(FileNameFolder).CopyHere _
'oApp.Namespace(Fname).items.Item("test.txt")
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub
DefPath = "C:\Users\tr1k5320\Desktop\mail dataları\default.zip\"
Bu forumu görüntüleyenler: AhrefsBot, Google [Bot] ve 3 misafir