kapalı excel dosyalarından resimleri çıkartmak

[kakara]

merhaba ustadlarım.

elimde tek klasör ıcınde 2000 adet excel dosyası var ve bu dosyların içlerinde jpg formatında resımler var. ben bu excellerın ıcındekı resımlerı baska bır klsöre toplamak ıstıyorum ( resım kalıtelerı bozulmadan ). resımlerı toplarken hangı excelden aldıysa o excelın ısmını resım ısmı olarak yazması gerekıyor . bir excelın ıcınde ıkı veyaz uc resım olarabılır bırıncı resım ıcın 1.çektıgı excel ısmı .. ıkıncı resme 2.çektıgı excel ısmı (aynı excelde bulunan ıkı resım ıcın ) olarak ayırabılırsek muthıs olur. bılmıyorum yapılabılme ıhtımalı var mı. şimdiden ılgınız ıcın tesekkur ederım.

 

[programer]

Merhaba,
Umarım işinizi görür. Ama 2000 dosya için ne kadar hızlı çalışır bilmem.
İyi Çalışmalar.

Linki ekledim ama bir an önce altın üyelik almanızı tavsiye ederim.

Deneme_Resim_Aktar.xls dosyasını indir - download

Deneme_Resim_Aktar.xls dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s5.dosya.tc

 

[kakara]

@programer ustadım ılgınız ıcın cok tesekkur ederım yalnız altın uye olmadıgım ıcın dosyayı ındıremıyorum alternatıf bır lınk koyabılır mısınız ? rıca etsem.

 

[kakara]

@programer ustadım calısmanızı denıyordum yalnız excelın ıcındekı resımlerı alıp hangı klasöre kayıt edıyor. burayı anlıyamadım da

 

[programer]

Hangi klasörü seçerseniz o klasörün içine çıkarıyor.
Aşağıdaki kottaki Export Filename yerini değiştire bilirsiniz.

'grafiği jpg olarak kaydet
.Export Filename:=Sht.Parent.Path & "\" & wb.Name & "-" & "Picture-" & pictureNumber & ".jpg", FilterName:="jpg"

 

[kakara]

@programer ustadım zamanınızı calmak ıstemıyorum fakat yapamadım. suan sızın kodlarınızla bılgısayarın hangı klasorune kayıt edıyor acaba ben o klasoru kullansam da olur.

.Export Filename: ısmıne kendı klasor ısmımı yazdıgımda hata verıyor cunku

 

[programer]

@programer ustadım zamanınızı calmak ıstemıyorum fakat yapamadım. suan sızın kodlarınızla bılgısayarın hangı klasorune kayıt edıyor acaba ben o klasoru kullansam da olur.

.Export Filename: ısmıne kendı klasor ısmımı yazdıgımda hata verıyor cunku

Şöyle söyleyeyim ozaman siz resimleri çıkartmak istediğiniz excel dosyalarının olduğu bir klasör seçiyorsunuz. İşte o seçtiğiniz klasörün içine çıkartıyor resimleri.

 

[kakara]

@programer ustadım ılgınız ıcın tesekkur ederım fakat dugmeye tıkladıgımda işlem tamam yazısına kadar gelıyor ama sectıgım klasorun ıcıne excellerden resımlerı dısarı aktarmıyor.

 

[programer]

Kusura bakmayın bir ayrıntıyı atlamışım.

 

[kakara]

@programer estagfurullah ustadım. verdıgınız komutlarda bır degısıklık varsa alternatıf bır lınkten paylasmanız mumkun mu acaba

 

[programer]

Mümkünse excel dosyalarında birini ekler misiniz. Yada paylaşır mısınız.

 

[kakara]

@programer ustadım

_BAYAN_XL_LI__KOLSUZ_TUNIK_3-4_KOL_SABAHLIK_TAKIMM.xlsx dosyasını indir - download

_BAYAN_XL_LI__KOLSUZ_TUNIK_3-4_KOL_SABAHLIK_TAKIMM.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s5.dosya.tc

 

[programer]

If InStr(Sht.Shapes(n).Name, "Resim") > 0 Then

Kod Satırını

If InStr(Sht.Shapes(n).Name, "Picture") > 0 Then

Olarak değiştirip dener misiniz.

 

[kakara]

@programer çok tesekkur ederım ustadım bırkaç excellı klasörde denedım calıstı saolun tekrardan

 

[programer]

Rica ederim işe yaradı ise ne mutlu bize. Kolay gelsin.

 

[Korhan Ayhan]

Merhaba,

Bende konuyu biraz araştırdım. Farklı bir teknik olarak Winrar programı aracılığı ile işlemin yapılabileceğini öğrendim.

Sisteminizde WinRAR yüklü ise aşağıdaki kodu deneyebilirsiniz. Bende 64 Bit Winrar yüklü olduğu için aşağıdaki program yolunu kullandım.

"C:\Program Files\WinRAR\WinRAR.exe"

Sizde program yolu ne ise kodun içinde bu satırı bulup revize etmelisiniz.

Kodu boş bir excel dosyasıa uygulayınız. Sonra bu dosyayı 2000 adet excel dosyanızın bulunduğu klasöre taşıyıp kodu çalıştırınız.

Ben 100 excel dosyası üzerinde denedim. Dosyalarda 2 sayfa ve 2 resim bulunuyordu.

İşlem yaklaşık 100 saniye sürdü. Siz 2000 dosyadan bahsetmiştiniz. Bu durumda sürenin 2000 saniye civarında sürmesi gerekir. Diğer arkadaşımızın önerdiği kod belki daha kısa sürede sonuç veriyordur. Ben denemesini yapmadım. Alternatif olması bakımından kodu paylaşmak istedim.

Eksikleri olabilir. Geliştirilebilir.

Option Explicit

#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub Export_Images_In_Excel_Files()
    Dim File_Path As String, My_File As String, Old_Name As String
    Dim Rar_File_Name As String, Rar_Extract, Picture_File As Object
    Dim FSO As Object, Picture_Count As Long, Process_Time As Double
   
    Process_Time = Timer
   
    Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
   
    File_Path = ThisWorkbook.Path & "\"
   
    If Dir(File_Path & "Extract File\", vbDirectory) = "" Then
        MkDir File_Path & "Extract File\"
    Else
        If FSO.GetFolder(File_Path & "Extract File\").Files.Count > 0 Then
            Kill File_Path & "Extract File\*.*"
        End If
    End If
   
    If Dir(File_Path & "Picture Folder\", vbDirectory) = "" Then
        MkDir File_Path & "Picture Folder\"
    Else
        If FSO.GetFolder(File_Path & "Picture Folder\").Files.Count > 0 Then
            Kill File_Path & "Picture Folder\*.*"
        End If
    End If
   
    My_File = Dir(File_Path & "*.xls*")

    While My_File <> ""
        If My_File <> ThisWorkbook.Name Then
            Old_Name = File_Path & My_File
            Rar_File_Name = File_Path & FSO.GetBaseName(My_File) & ".rar"
           
            FileCopy Old_Name, Rar_File_Name
           
            If FSO.GetFolder(File_Path & "Extract File\").Files.Count > 0 Then
                Kill File_Path & "Extract File\*.*"
            End If
           
            Rar_Extract = VBA.Shell(Chr(34) & "C:\Program Files\WinRAR\WinRAR.exe" & _
                          Chr(34) & " e " & Chr(34) & Rar_File_Name & Chr(34) & " " & _
                          Chr(34) & File_Path & "Extract File\", vbHide)
                         
            Sleep 100
           
            Kill File_Path & FSO.GetBaseName(My_File) & ".rar"
           
            Picture_Count = 0
           
            For Each Picture_File In FSO.GetFolder(File_Path & "Extract File\").Files
                If UCase(FSO.GetExtensionName(Picture_File)) = "PNG" Then
                    Picture_Count = Picture_Count + 1
                    FileCopy Picture_File, _
                             File_Path & "Picture Folder\" & FSO.GetBaseName(My_File) & _
                             "-" & Format(Picture_Count, "00000") & "." & FSO.GetExtensionName(Picture_File)
                End If
            Next
        End If
        My_File = Dir
    Wend
   
    FSO.Deletefolder File_Path & "Extract File", False
   
    Set FSO = Nothing
   
    Process_Time = Timer - Process_Time
   
    If Process_Time > 60 Then
        MsgBox "Processing time ; " & FormatDateTime(Process_Time / 86400, 3)
    Else
        MsgBox "Processing time ; " & Format(Process_Time, "0.00") & " Second"
    End If
End Sub

 

[Zeki Gürsoy]

Konu çözülmüş ama hızlı bir yöntem olarak kendi yazdığım sınıfları da kullanabiliriz.

Not : Kodlar ve dosyalar @Zeki Gürsoy beyin talebi üzerine 29/09/2021 22:10 tarihinde revize edilmiştir.

Option Explicit

Public Sub Test()
'BUG: ExtractImages metodu çağrıldığında Dir fonksiyonu ilk dosya dışındakileri görmüyor.
'     Bu nedenle önce koleksiyon veya diziye alınmalı.
    Dim srcFolder As String, destFolder As String, strFile As String
    Dim varFile, t, strArr() As String, counter As Long
    
    t = Timer
    
    srcFolder = ThisWorkbook.Path & "\"
    destFolder = srcFolder & "Picture Folder" & "\"
    
    strFile = Dir(srcFolder & "*.xlsx")
    
    Do While strFile <> ""
        ReDim Preserve strArr(counter) As String
        strArr(counter) = srcFolder & strFile
        strFile = Dir
        counter = counter + 1
    Loop
    
    For Each varFile In strArr
        ExtractImages varFile, destFolder
    Next

    MsgBox Timer - t
End Sub
    
Private Sub ExtractImages(ByVal xlFile As String, ByVal dstFolder As String)
    Dim arc As ZipArchive, entry, entry2 As ZipArchiveEntry, strImageName As String
    
    Set arc = ZipFile.OpenRead(xlFile)
    
    For Each entry In arc.Entries.ToArray
        If entry.Name Like "*.png" Then
            Set entry2 = arc.GetEntry(entry.FullName)
            strImageName = dstFolder & Left$(Dir(xlFile), Len(Dir(xlFile)) - 5) & "-" & entry2.Name
            entry2.ExtractToFile strImageName, True
        End If
    Next
    
    arc.Dispose
End Sub

 

[programer]

Sayın Korhan bey ve Zeki bey Elinize sağlık. Bu yöntemi bende gördüm ama bilgi konusunda yeterince bilgim olmadığı için hiç girmedim. Çok güzel bir çalışma olmuş oldu tekrar elinize sağlık.

 

[Korhan Ayhan]

Sleep fonksiyonunu kullanarak süreyi biraz daha efektif hale getirdim. #16 nolu mesajımda ki kodu bu yönde revize ettim.

 

[kakara]

üstadlarım ılgıınız ıcın cok tesekkur ederım tum calısmaları deneyıp donuslerını yapıcam