ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[feridunabi]

Arkadaşlar "d:\dosyalar\deneme.zip" dosyasını winrar kullanarak, excel içinden dosyanın bulunduğu klasöre nasıl açabilirim.

[Muhammet AYTAŞ]

Merhaba feridunabi(abi nerden tamışıyorduk )
Webte UnRar.ocx ile ilgili bir örnek buldum ve VB6'da düzenledim.
Şu ocx al buraya kopyala falan anlatması ve anlaması zor olabileceğinden çalışmamı doğrudan setup haline getirdim ki gerekli ocx ve dll dosyaları ilgili yerlere setup dosyası kendisi kopyaların ve register etsin.
Ek olarak VB6 proje dsoyalarını da veriyorum ki isteyen kodlara bakıp Excel'e uyarlayabilsin.
Yalnız bu çalışma rar uzantılı dosyalar için.
Buradan indiriniz.

[feridunabi]

Excel'e uyarlanmış hali yok mu?

[Muhammet AYTAŞ]

VB'de gayet güzel çalışırken referansını Excel'e eklemeye çalıştığımda bende hata verdi.

İsterseniz altta verdiğim zip paketlerini açan ve zip paketi oluşturan kodları deneyin.

Kod: Tümünü seç

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

[feridunabi]

Hocam ilgin için çok teşekkür ederim.
Bu kodu kullanmak için winzip programı kurulu olması lazım. Benim istediğim winrar ile yapması.
Veya, ziplenmiş kodları windowsun kendi bileşeniyle açması. Yani sistemimde winzip programını kurmak istemiyorum.

[Muhammet AYTAŞ]

İyi güzel de extract etmek istideğiniz dosya zip uzantılı.
Zip dosyasını ille ki WinRar ile mi açmak istiyorsunuz?
Normalde WinRAR zip uzantıları desteklediğini biliyoruz, ama iş kodlamaya gelince bu mümkün mü, emin değilim, denemek lazım.

[feridunabi]

Evet hocam zip dosyalarını winrar ile açmak istiyorum. Veya windowsun kendi bileşenleriyle.(Böyle olursa program kurulmasına gerek kalmaz.)

[Muhammet AYTAŞ]

Bu kodları deneyin bakalım istediğinizi karşılayacak mı? Hem zip hem rar paketi için kullanabilirsiniz.

Kod: Tümünü seç

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

[Bülent]

Muhammet hocam, şöyle bir şey buldum, müsadenizle;

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Ş]

Estafirullah, Bülent hoca.
İşyerinde olduğımdan gönderdiğin kodları denemedim, ama gördüğüm kadarıyla senin kodlar daha sade ve kullanışlı.
Bence feridunabi senin kodları kendine uyarlayıp kullasın derim.
Benim kodlar uzun ve biraz karışık.
Aslında şöyle ilk bakışta bu kod kalabalığı insanı şaşırtabilir, çünkü asıl işi yapan birkaç satır var.
Ama klasör ve ya dosya isimlerinde boşluk olunca burada işin yapan Shell komutu hata veriyor.
Dolayısıyla bu kod kalabalığı da o boşluk ihtimaline karşılık zaren.
Ama dediğim gibi arkadaş en iyisi senin kodları kendine uyarlasın.

[Bülent]

Ama dediğim gibi arkadaş en iyisi senin kodları kendine uyarlasın.

Çeşit sunduk, dilediğini kullansın.
Hem bu kadar çeşitliliği baharatçıda bile bulmak zor.

[feridunabi]

Çok teşekkür ederim.
Winrar programına gerek kalmadan dosyaları açabildim.
Süpersiniz...

[Murat OSMA]

Çeşit sunduk, dilediğini kullansın.
Hem bu kadar çeşitliliği baharatçıda bile bulmak zor.

Bülent bey, doğru söylüyor...

[kavakli313]

Muhammet hocam, şöyle bir şey buldum, müsadenizle;

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

bülent hocam acaba şifreli rar dosyasına uygulayabilirmiyiz.

[emre.kuscu]

Merhabalar kodlar benimde işime yariyacak gibi gözüküyor. Ama kodların çalışması hakında birza bilgi verirseniz sevinirim.

Kod: Tümünü seç

DefPath = "C:\Users\tr1k5320\Desktop\mail dataları\default.zip\"

Bu kod açILMASINI istediğim zipli dosyanın adresi olması LZAIM diye anladım. Ama bunu yazdığımda sadece C:\Users\tr1k5320\Desktop\ buraya kadar acıyor. Genel olarak kodların tanımını yaparsanız sizleri fazla rahatsız etmeden çözüme ulaşabilirim.
Kolay gelsin