Nesneleri Dışa Aktarma

[Ouzz_z]

Nesne olarak eklenmiş pdf dosyaları bulunan bir excel dosyam mevcut. Bu pdf nesnelerini tek tek açıp kaydetmek yerine topluca bir klasöre nasıl taşıyabilirim?

 

[pitchoute]

Merhaba, yedek alıp dener misiniz;

Sub PDFOleNesneleriniDisaAktar()
    Dim objOLE As OLEObject
    Dim strKlasorYolu As String
    Dim strGeciciDosyaYolu As String
    Dim intSayac As Integer
    Dim objFSO As Object
    Dim objTempFolder As Object
    strKlasorYolu = "C:\PDFNesneleri\"

    If Dir(strKlasorYolu, vbDirectory) = "" Then
        MkDir strKlasorYolu
    End If
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTempFolder = objFSO.GetSpecialFolder(2) 
    intSayac = 0

    For Each objOLE In ActiveSheet.OLEObjects
        If InStr(1, objOLE.ProgID, "PDF", vbTextCompare) > 0 Or _
           InStr(1, objOLE.OLEClass, "PDF", vbTextCompare) > 0 Then
            intSayac = intSayac + 1
            strGeciciDosyaYolu = objTempFolder & "\Temp_PDF_" & intSayac & ".pdf"
           
            On Error Resume Next
            objOLE.Object.SaveAs strGeciciDosyaYolu
           
            If Err.Number = 0 Then
                objFSO.CopyFile strGeciciDosyaYolu, strKlasorYolu & "PDF_Nesne_" & intSayac & ".pdf", True
                objFSO.DeleteFile strGeciciDosyaYolu, True
            Else
                objOLE.Verb xlPrimary
                Application.SendKeys "%{TAB}"
                Application.SendKeys "^s"
                Application.Wait Now + TimeValue("0:00:01")
                Application.SendKeys strKlasorYolu & "PDF_Nesne_" & intSayac & ".pdf"
                Application.SendKeys "{ENTER}"
                Application.Wait Now + TimeValue("0:00:01")
                Application.SendKeys "%{F4}"
            End If
            On Error GoTo 0
        End If
    Next objOLE
    If intSayac > 0 Then
        MsgBox intSayac & " PDF nesnesi " & strKlasorYolu & " klasörüne kaydedildi.", vbInformation
    Else
        MsgBox "Aktif sayfada PDF nesnesi bulunamadı.", vbExclamation
    End If
    Set objFSO = Nothing
    Set objTempFolder = Nothing
End Sub

 

[Ouzz_z]

Shape olarak değil, OLEObjects olarak tanımlı bu nesneler. O yüzden hiçbirini görmedi.

 

[pitchoute]

Kodu düzenledim.

 

[Ouzz_z]

Hata verdi

 

[pitchoute]

Şöyle deneyebilir misiniz;

Sub PDFOleNesneleriniDisaAktar()
    Dim objOLE As OLEObject
    Dim strKlasorYolu As String
    Dim intSayac As Integer
    Dim strDosyaAdi As String
    
    strKlasorYolu = "C:\PDFNesneleri\"
    
    If Dir(strKlasorYolu, vbDirectory) = "" Then
        MkDir strKlasorYolu
    End If
    
    intSayac = 0
    
    For Each objOLE In ActiveSheet.OLEObjects
        If InStr(1, objOLE.ProgID, "PDF", vbTextCompare) > 0 Or _
           InStr(1, objOLE.OLEClass, "PDF", vbTextCompare) > 0 Then
            
            intSayac = intSayac + 1
            strDosyaAdi = strKlasorYolu & "PDF_Nesne_" & intSayac & ".pdf"
            
            On Error Resume Next
            objOLE.Activate
            Application.Wait Now + TimeValue("0:00:01")
            Application.SendKeys "^s"
            Application.Wait Now + TimeValue("0:00:02")
            Application.SendKeys strDosyaAdi
            Application.Wait Now + TimeValue("0:00:01")
            Application.SendKeys "{ENTER}"
            Application.Wait Now + TimeValue("0:00:02")
            Application.SendKeys "%{F4}"
            Application.Wait Now + TimeValue("0:00:01")
            
            If Err.Number <> 0 Then
                Debug.Print "Hata: " & Err.Number & " - " & Err.Description & " Nesne: " & intSayac
            End If
            On Error GoTo 0
        End If
    Next objOLE
    If intSayac > 0 Then
        MsgBox intSayac & " PDF nesnesi " & strKlasorYolu & " klasörüne kaydedildi.", vbInformation
    Else
        MsgBox "Aktif sayfada PDF nesnesi bulunamadı.", vbExclamation
    End If
End Sub

 

[Ouzz_z]

Yine aynı satır hata verdi, biraz araştırdım da vba ile çıkartmak mümkün değil görünüyor. Excel dosyasının uzantısını zip yapınca gömülü pdf'ler görünüyor ama o dosyaların pdf olmasını sağlayacak şekilde sadeleştirilmesi için de c# veya python gerekiyor.

 

[Korhan Ayhan]

Bu linkte paylaşılan linkler işe yarayabilir... İrdelemek gerekiyor..

Exceldeki resimleri dışarı çıkartma

Merhaba I sutununda her hücrede resimler var ve sırasıyla resim1 resim2 ... şeklinde adlandırarak C:\Users\Pc\Desktop\Yeni Klasörünün içine indirmesini istiyorum sabahtan beri uğraşıyorum yapamadım acil bir şekilde yardım edebilcek üstadım var mı teşekkürler(Birde jpg formatında olursa mükkemmel...

www.excel.web.tr

 

[Ouzz_z]

o yöntemle görülüyor ancak pdf kısmını ayırmak sıkıntı. bin uzantısıyla saklanıyor çünkü. Yaklaşık 500 tane pdf gömmüşler dosyaya.

 

[Zeki Gürsoy]

Merhaba, şunu deneyin...

Not: Bazen "Copy yöntemi başarısız" şeklinde tutarsız davranabiliyor. Birkaç kez tekrar çalıştırmayı deneyin.

Sub ExtractPDFs()
    Dim dst, oShell As Object, obj As OLEObject, ws As Worksheet
    
    dst = Environ$("userprofile") & "\Desktop\ExtractedPDFs"
    
    If Dir(dst, vbDirectory) = "" Then
        MkDir dst
    Else
        If Dir(dst & "\*.*") <> "" Then Kill dst & "\*.*"
    End If
    
    Set oShell = CreateObject("Shell.Application").Namespace(dst).Self
    
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Visible Then ws.Visible = True
        
        For Each obj In ws.OLEObjects
            obj.Copy
            oShell.InvokeVerb "Paste"
        Next
    Next
    
    MsgBox "İşlem yapıldı"
End Sub

 

[Ouzz_z]

Object 21 ve Shape_59 gibi ada sahip objelerde geziyor ama klasörde bir pdf oluşmuyor.

 

[muratboz06]

Sorunuzu yapay zekaya sordum. Cevap linktedir.

ChatGPT - Excel PDF Dışa Aktarma

Shared via ChatGPT

chatgpt.com

Kod, Adobe Acrobat yüklü olmasını ve varsayılan PDF açıcı olmasını varsayar.

 

[muratboz06]

Microsoft Edge pdf görüntüleme için varsayılan program olarak seçip aşağıdaki kodları da deneyebilirsiniz.
sPath = "C:\XXX\" satırını pdf leri çıkartmak istediğiniz klasör ismiyle değiştiriniz.

Option Explicit

'Note: the extracted PDF files should open in Microsoft Edge _
They will not open in Acrobat reader


Sub ExtractPDF()
    Dim FName As Variant
    Dim TmpPath As Variant
    Dim FSO As Object
    Dim oApp As Object
    Dim sPath As String
    Dim Output As String
    Dim f As String
    Dim i As Long, j As Long
    Dim ftype As String
    'Set location and output; adjust as required
    sPath = "C:\XXX\"
    Output = "PDFfile" & Format(Now, " yy_mm_dd_hh_mm")
    ftype = ".pdf"
    'Create Objects
    Set FSO = CreateObject("scripting.filesystemobject")
    Set oApp = CreateObject("Shell.Application")
    'Set paths and create folders
    TmpPath = sPath & "MyUnzipFolder"
    FName = sPath & "Data.zip"
    On Error Resume Next
    FSO.deletefolder TmpPath
    FSO.deletefolder sPath & "PDF"  'Deletes previously extracted files
    MkDir sPath & "PDF"
    MkDir TmpPath
    On Error GoTo 0
    'Make copy of workbook as zip file
    ActiveWorkbook.SaveCopyAs FName
    'Unzip bin files
    For j = 1 To oApp.Namespace(FName).items.Count
        oApp.Namespace(TmpPath).CopyHere oApp.Namespace(FName).items.Item("xl\embeddings\oleObject" & j & ".bin")
        f = TmpPath & "\oleObject" & j & ".bin"
        If Len(Dir(f)) = 0 Then Exit For
        Name f As sPath & "PDF\" & Output & Format(j, " - 00") & ftype
    Next j
    'Clean up and view files
    FSO.deletefolder TmpPath
    Shell "explorer.exe " & sPath & "PDF", vbNormalFocus
End Sub

 

[Ouzz_z]

Üzgünüm ama hiçbiri çalışmıyor. Murat Bey'in 13 numaralı cevabı birkaç pdf oluşturdu ancak dosyalar bozuk. İsterseniz örnek üzerinden deneyebilirsiniz.

 

[Zeki Gürsoy]

Murat beyin çıkardığı bin dosyalar pdf değildir. Compound, yani kabaca zip gibi pakettir; ancak zip değildir. Pdf dosyasının alınabilmesi için harici library gereklidir. (Şimdi değil ama, ilerleyen bir zamanda bunu yazabilirim)

.