PDF dosyasından veri alma

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu dosyada korumasız ve kopyalamaya izin verilen pdf dosyalarından text olarak verileri dosyaya sayfa ekleyerek kopyalama ile veri almaktadır kopyalama işlemleri
klavyenin CTRL+C tuşları ile (SendKeys "^c", True) yapmaktadır.

Örnek pdf dosyalarından bir tanesinin sayfası korumalı yanı kopyalamaya engel durumdadır. bu dosyadan veri alamamaktadır.

Not : Bu kod aktif sayfa dışındaki bütün sayfaları siler

Kod:
#If VBA7 Then
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

#Else

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
#End If

Dim sayfa
Dim kalasor1

Sub veri_al()
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
sayfa = Activesheet.Name
kalasor1 = ActiveWorkbook.Name
Worksheets(sayfa).Range("A2:D" & Rows.Count).ClearContents
Worksheets(sayfa).Cells(1, 1) = "PDF Dosya Yolu"
Worksheets(sayfa).Cells(1, 2) = "Pdf Dosya Adı"
Worksheets(sayfa).Cells(1, 3) = "PDF Sayfa Sayısı"
Worksheets(sayfa).Cells(1, 4) = "Sonuç"

sayfalarıseç1
Liste (Kaynak)
Sheets(sayfa).Select

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
Dim zaman As Long
On Error Resume Next
For Each dosya In fL.GetFolder(yol).Files
If LCase(fL.GetExtensionName(dosya)) = "pdf" Then 'uzantı

j = WorksheetFunction.CountA(Worksheets(sayfa).Range("a1:a" & Rows.Count)) + 1
Worksheets(sayfa).Cells(j, 1) = yol & ekle & dosya.Name
Worksheets(sayfa).Cells(j, 2) = fL.GetBaseName(dosya.Name)


aranan1 = fL.GetBaseName(dosya.Name)
son = Worksheets(sayfa).Cells(Rows.Count, "A").End(3).Row
fazla = Val(WorksheetFunction.CountIf(Worksheets(sayfa).Range("B2:B" & son), aranan1))
'If WorksheetFunction.CountIf(Worksheets(sayfa).Range("B1:B" & son), aranan1) = 1 Then


If fazla = 1 Then ekle = ""
If fazla > 1 Then ekle = "_" & fazla - 1


Dim MyData As String, strData() As String
Dim RegExp
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
Open dosya For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
pdfsayi = RegExp.Execute(MyData).Count

Worksheets(sayfa).Cells(j, 3) = pdfsayi
sat = Worksheets(sayfa).Cells(j, 3)

say = Sheets.Count + 1
Sheets.Add
Sheets(Activesheet.Name).Move After:=Sheets(say)
Sheets(Activesheet.Name).Name = fL.GetBaseName(dosya.Name) & ekle


Columns("A:A").NumberFormat = "@"
Range("A1").Select


ShellExecute 0, "Open", dosya, "", "", vbNormalNoFocus
Application.Wait (Now + TimeValue("0:00:02"))

SendKeys "^a", True

Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "^c", True



If sat <= 2 Then
zaman = 1
ElseIf sat >= 3 And sat <= 6 Then
zaman = 2
ElseIf sat >= 7 And sat <= 12 Then
zaman = 5
ElseIf sat >= 13 And sat <= 24 Then
zaman = 10
ElseIf sat >= 25 And sat <= 50 Then
zaman = 15
ElseIf sat >= 51 And sat <= 100 Then
zaman = 20
ElseIf sat >= 101 Then
zaman = 25
End If


basla = Timer
bekle = zaman
While Timer < basla + bekle
DoEvents
Wend


Application.Wait (Now + TimeValue("0:00:01"))
Windows(kalasor1).Activate
Range("a1").Select


Application.Wait (Now + TimeValue("0:00:01"))

Shell "TASKKILL /F /IM AcroRd32.exe"
Application.Wait (Now + TimeValue("0:00:01"))

Sheets(Activesheet.Name).Cells(1, 1).Value = "Bu dosyadan veri alaınamadı dosya korumalı veya kopyalamaya engelli olabilir"

'Activesheet.Paste Destination:=Worksheets(Activesheet.Name).Range("a1")

Sheets(Activesheet.Name).Range("a1").PasteSpecial Paste:=1



If Left(Sheets(Activesheet.Name).Cells(1, 1).Value, 11) = "Bu dosyadan" Then
Worksheets(sayfa).Cells(j, 4) = "Bu dosyadan veri alaınamadı dosya korumalı veya kopyalamaya engelli olabilir"
End If


Application.CutCopyMode = False

OpenClipboard (0&)
EmptyClipboard
CloseClipboard

End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Sub sayfalarıseç1()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
Dim sayfa As String
Dim deg, a
j = 0
For i = 1 To Sheets.Count
sayfa = Sheets(i).Name
If Sheets(Sheets(i).Name).Visible = True Then
If sayfa = Activesheet.Name Then
Else
ReDim Preserve myArray(j)
myArray(j) = i
deg = Sheets(i).Name & Chr(10) & deg
j = j + 1
End If
End If
Next i

If j > 0 Then
Sheets(myArray).Select
Sheets(myArray).Delete

End If
Worksheets(Activesheet.Name).Range("A2:D" & Rows.Count).ClearContents
Worksheets(Activesheet.Name).Cells(1, 1) = "PDF Dosya Yolu"
Worksheets(Activesheet.Name).Cells(1, 2) = "Pdf Dosya Adı"
Worksheets(Activesheet.Name).Cells(1, 3) = "PDF Sayfa Sayısı"
Worksheets(Activesheet.Name).Cells(1, 4) = "Sonuç"



Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 

Ekli dosyalar

Son düzenleme:

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
1 nolu mesajdaki dosya güncellendi
 

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,580
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Teşekkürler Sayın Halit3 Hocam
Saygılarımla
 

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,580
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Sayın Halit Hocam,
Bir örnek çalışma sonucu.
Sadece üst bölümdeki bilgileri doğru alabilmek mümkün müdür?
Saygılarımla
 

Ekli dosyalar

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu uygulamada kopyala yapıştır ile veri alınıyor
Söyle yapabilirsiniz veri alındıktan sonra farklı bir sayfa veya dosyaya veri alınan sayfadan istenilen hücredeki bilgileri alabilirsiniz.
 

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,580
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Evet Sayın Hocam,
Ama dikkat etti iseniz sınıf ve numara doğru gelmiyor. O açıdan sordum.
Saygılarımla
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Evet Sayın Hocam,
Ama dikkat etti iseniz sınıf ve numara doğru gelmiyor. O açıdan sordum.
Saygılarımla
1 nolu mesajdaki dosyaya
Kod:
Cells.NumberFormat = "@"
Range("A1").Select
bunları ekledim

sınıf 3 satırda numara ise 98 satıra geliyor.
 

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,580
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Merhaba Arkadaşlar,
Numara bazı (aynı kalıp) dosyalarda 96. satırda geliyor. Önemli değil. Elinize sağlık. Hepinize teşekkür ederim.
Saygılarımla
 

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,580
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Ayrıca size de teşekkür ederim Haluk Hocam,
Saygılarımla
 

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,270
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Haluk bey kodun kaynağını hatırlamıyorum.
Herhalde bu siteden almış olmam lazım
Yukarıdaki mesajımda, söz konusu fonksiyonun kullanıldığı 11 tane link var. Hepsi de kaynağını açıkça belirtmiş.

Siz muhtemelen 10. sıradaki linkten almışınızdır....

.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Evet Muhtemelen öyledir.

Aşağıdaki linkde buna benzer örnek var sadece
RegExp = CreateObject("VBscript.RegExp") operatör kullanmak gerekiyor.
püf nokta burası ("/Type\s*/Page[^s]") (Ben burayı bilmiyorum)

https://stackoverflow.com/questions/20128115/input-past-end-of-file-vba-excel

linkdeki kod

Kod:
Sub Sample()
    Dim MyData As String, strData() As String
    Dim i As Long

    '~~> Replace your file here
    Open "C:\MyFile.Txt" For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1
    strData() = Split(MyData, vbCrLf)

    '
    '~~> Now strData has all the data from the text file
    '

    For i = LBound(strData) To UBound(strData)
        Debug.Print strData(i)
        '
        '~~> What ever you want here
        '
    Next i
End Sub
bende bunu bu şekilde düzenledim.

Kod:
Sub pdf_sayfa_sayısı()
Dim MyData As String, strData() As String
Dim RegExp
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
dosya = ThisWorkbook.Path & "\dene3.pdf"
Open dosya For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
MsgBox RegExp.Execute(MyData).Count
End Sub
 
Son düzenleme:

baydeniro

Altın Üye
Katılım
26 Ocak 2007
Mesajlar
4,625
Excel Vers. ve Dili
Ofis 2016
Bu dosyada korumasız ve kopyalamaya izin verilen pdf dosyalarından text olarak verileri dosyaya sayfa ekleyerek kopyalama ile veri almaktadır kopyalama işlemleri
klavyenin CTRL+C tuşları ile (SendKeys "^c", True) yapmaktadır.

Örnek pdf dosyalarından bir tanesinin sayfası korumalı yanı kopyalamaya engel durumdadır. bu dosyadan veri alamamaktadır.

Not : Bu kod aktif sayfa dışındaki bütün sayfaları siler

Kod:
#If VBA7 Then
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

#Else

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
#End If

Dim sayfa
Dim kalasor1

Sub veri_al()
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
sayfa = Activesheet.Name
kalasor1 = ActiveWorkbook.Name
Worksheets(sayfa).Range("A2:D" & Rows.Count).ClearContents
Worksheets(sayfa).Cells(1, 1) = "PDF Dosya Yolu"
Worksheets(sayfa).Cells(1, 2) = "Pdf Dosya Adı"
Worksheets(sayfa).Cells(1, 3) = "PDF Sayfa Sayısı"
Worksheets(sayfa).Cells(1, 4) = "Sonuç"

sayfalarıseç1
Liste (Kaynak)
Sheets(sayfa).Select

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
Dim zaman As Long
On Error Resume Next
For Each dosya In fL.GetFolder(yol).Files
If LCase(fL.GetExtensionName(dosya)) = "pdf" Then 'uzantı

j = WorksheetFunction.CountA(Worksheets(sayfa).Range("a1:a" & Rows.Count)) + 1
Worksheets(sayfa).Cells(j, 1) = yol & ekle & dosya.Name
Worksheets(sayfa).Cells(j, 2) = fL.GetBaseName(dosya.Name)


aranan1 = fL.GetBaseName(dosya.Name)
son = Worksheets(sayfa).Cells(Rows.Count, "A").End(3).Row
fazla = Val(WorksheetFunction.CountIf(Worksheets(sayfa).Range("B2:B" & son), aranan1))
'If WorksheetFunction.CountIf(Worksheets(sayfa).Range("B1:B" & son), aranan1) = 1 Then


If fazla = 1 Then ekle = ""
If fazla > 1 Then ekle = "_" & fazla - 1


Dim MyData As String, strData() As String
Dim RegExp
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
Open dosya For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
pdfsayi = RegExp.Execute(MyData).Count

Worksheets(sayfa).Cells(j, 3) = pdfsayi
sat = Worksheets(sayfa).Cells(j, 3)

say = Sheets.Count + 1
Sheets.Add
Sheets(Activesheet.Name).Move After:=Sheets(say)
Sheets(Activesheet.Name).Name = fL.GetBaseName(dosya.Name) & ekle


Columns("A:A").NumberFormat = "@"
Range("A1").Select


ShellExecute 0, "Open", dosya, "", "", vbNormalNoFocus
Application.Wait (Now + TimeValue("0:00:02"))

SendKeys "^a", True

Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "^c", True



If sat <= 2 Then
zaman = 1
ElseIf sat >= 3 And sat <= 6 Then
zaman = 2
ElseIf sat >= 7 And sat <= 12 Then
zaman = 5
ElseIf sat >= 13 And sat <= 24 Then
zaman = 10
ElseIf sat >= 25 And sat <= 50 Then
zaman = 15
ElseIf sat >= 51 And sat <= 100 Then
zaman = 20
ElseIf sat >= 101 Then
zaman = 25
End If


basla = Timer
bekle = zaman
While Timer < basla + bekle
DoEvents
Wend


Application.Wait (Now + TimeValue("0:00:01"))
Windows(kalasor1).Activate
Range("a1").Select


Application.Wait (Now + TimeValue("0:00:01"))

Shell "TASKKILL /F /IM AcroRd32.exe"
Application.Wait (Now + TimeValue("0:00:01"))

Sheets(Activesheet.Name).Cells(1, 1).Value = "Bu dosyadan veri alaınamadı dosya korumalı veya kopyalamaya engelli olabilir"

'Activesheet.Paste Destination:=Worksheets(Activesheet.Name).Range("a1")

Sheets(Activesheet.Name).Range("a1").PasteSpecial Paste:=1



If Left(Sheets(Activesheet.Name).Cells(1, 1).Value, 11) = "Bu dosyadan" Then
Worksheets(sayfa).Cells(j, 4) = "Bu dosyadan veri alaınamadı dosya korumalı veya kopyalamaya engelli olabilir"
End If


Application.CutCopyMode = False

OpenClipboard (0&)
EmptyClipboard
CloseClipboard

End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Sub sayfalarıseç1()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
Dim sayfa As String
Dim deg, a
j = 0
For i = 1 To Sheets.Count
sayfa = Sheets(i).Name
If Sheets(Sheets(i).Name).Visible = True Then
If sayfa = Activesheet.Name Then
Else
ReDim Preserve myArray(j)
myArray(j) = i
deg = Sheets(i).Name & Chr(10) & deg
j = j + 1
End If
End If
Next i

If j > 0 Then
Sheets(myArray).Select
Sheets(myArray).Delete

End If
Worksheets(Activesheet.Name).Range("A2:D" & Rows.Count).ClearContents
Worksheets(Activesheet.Name).Cells(1, 1) = "PDF Dosya Yolu"
Worksheets(Activesheet.Name).Cells(1, 2) = "Pdf Dosya Adı"
Worksheets(Activesheet.Name).Cells(1, 3) = "PDF Sayfa Sayısı"
Worksheets(Activesheet.Name).Cells(1, 4) = "Sonuç"



Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
üstad harika bir kod, çok teşekkürler
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu dosyada
Function Pagesayfa(PDF_File As String) As Long
prosüdürü kullanılmamıştır. bunun yerine referanslarda Acrobat.tlb dll dosyası kullanılmıştır.
Pagesayfa prosüdür bazı dosyaların sayfa sayısını tam vermemektedir.
Acrobat.tlb dosyasına ait link aşağıdadır.
https://www.excel.web.tr/threads/pdf-dosyalarini-birlestirme-ve-ayristirma-merge-split-islemleri.183098/


Kod:
#If VBA7 Then
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

#Else

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
#End If

Dim sayfa
Dim kalasor1




Sub veri_al()
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
sayfa = Activesheet.Name
kalasor1 = ActiveWorkbook.Name
Worksheets(sayfa).Range("A2:D" & Rows.Count).ClearContents
Worksheets(sayfa).Cells(1, 1) = "PDF Dosya Yolu"
Worksheets(sayfa).Cells(1, 2) = "Pdf Dosya Adı"
Worksheets(sayfa).Cells(1, 3) = "PDF Sayfa Sayısı"
Worksheets(sayfa).Cells(1, 4) = "Sonuç"

sayfalarıseç1
Liste (Kaynak)
Sheets(sayfa).Select

SendKeys ("{NUMLOCK}"), True

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
Dim zaman As Long
On Error Resume Next
For Each dosya In fL.GetFolder(yol).Files
If LCase(fL.GetExtensionName(dosya)) = "pdf" Then 'uzantı

j = WorksheetFunction.CountA(Worksheets(sayfa).Range("a1:a" & Rows.Count)) + 1
Worksheets(sayfa).Cells(j, 1) = yol & ekle & dosya.Name
Worksheets(sayfa).Cells(j, 2) = fL.GetBaseName(dosya.Name)


aranan1 = fL.GetBaseName(dosya.Name)
son = Worksheets(sayfa).Cells(Rows.Count, "A").End(3).Row
fazla = Val(WorksheetFunction.CountIf(Worksheets(sayfa).Range("B2:B" & son), aranan1))
'If WorksheetFunction.CountIf(Worksheets(sayfa).Range("B1:B" & son), aranan1) = 1 Then


If fazla = 1 Then ekle = ""
If fazla > 1 Then ekle = "_" & fazla - 1

'-------------------------------------------------------------
Dim pdDoc As Acrobat.CAcroPDDoc, newPDF As Acrobat.CAcroPDDoc
Set pdDoc = CreateObject("AcroExch.pdDoc")
pdDoc.Open (dosya)
'-------------------------------------------------------------
Worksheets(sayfa).Cells(j, 3) = pdDoc.GetNumPages
'-------------------------------------------------------------


sat = Worksheets(sayfa).Cells(j, 3)

say = Sheets.Count + 1
Sheets.Add
Sheets(Activesheet.Name).Move After:=Sheets(say)
Sheets(Activesheet.Name).Name = fL.GetBaseName(dosya.Name) & ekle

Columns("A:A").NumberFormat = "@"
Range("A1").Select


ShellExecute 0, "Open", dosya, "", "", vbNormalNoFocus
Application.Wait (Now + TimeValue("0:00:02"))

SendKeys "^a", True

Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "^c", True



If sat <= 2 Then
zaman = 1
ElseIf sat >= 3 And sat <= 6 Then
zaman = 2
ElseIf sat >= 7 And sat <= 12 Then
zaman = 5
ElseIf sat >= 13 And sat <= 24 Then
zaman = 10
ElseIf sat >= 25 And sat <= 50 Then
zaman = 15
ElseIf sat >= 51 And sat <= 100 Then
zaman = 20
ElseIf sat >= 101 Then
zaman = 25
End If


basla = Timer
bekle = zaman
While Timer < basla + bekle
DoEvents
Wend


Application.Wait (Now + TimeValue("0:00:01"))
Windows(kalasor1).Activate
Range("a1").Select


Application.Wait (Now + TimeValue("0:00:01"))

Shell "TASKKILL /F /IM AcroRd32.exe"
Application.Wait (Now + TimeValue("0:00:01"))

Sheets(Activesheet.Name).Cells(1, 1).Value = "Bu dosyadan veri alaınamadı dosya korumalı veya kopyalamaya engelli olabilir"

Activesheet.Paste Destination:=Worksheets(Activesheet.Name).Range("a1")

Sheets(Activesheet.Name).Range("a1").PasteSpecial Paste:=1



If Left(Sheets(Activesheet.Name).Cells(1, 1).Value, 11) = "Bu dosyadan" Then
Worksheets(sayfa).Cells(j, 4) = "Bu dosyadan veri alaınamadı dosya korumalı veya kopyalamaya engelli olabilir"
End If


Application.CutCopyMode = False

OpenClipboard (0&)
EmptyClipboard
CloseClipboard

End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Sub sayfalarıseç1()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
Dim sayfa As String
Dim deg, a
j = 0
For i = 1 To Sheets.Count
sayfa = Sheets(i).Name
If Sheets(Sheets(i).Name).Visible = True Then
If sayfa = Activesheet.Name Then
Else
ReDim Preserve myArray(j)
myArray(j) = i
deg = Sheets(i).Name & Chr(10) & deg
j = j + 1
End If
End If
Next i

If j > 0 Then
Sheets(myArray).Select
Sheets(myArray).Delete

End If
Worksheets(Activesheet.Name).Range("A2:D" & Rows.Count).ClearContents
Worksheets(Activesheet.Name).Cells(1, 1) = "PDF Dosya Yolu"
Worksheets(Activesheet.Name).Cells(1, 2) = "Pdf Dosya Adı"
Worksheets(Activesheet.Name).Cells(1, 3) = "PDF Sayfa Sayısı"
Worksheets(Activesheet.Name).Cells(1, 4) = "Sonuç"



Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 

Ekli dosyalar

Katılım
14 Mart 2017
Mesajlar
7
Excel Vers. ve Dili
Microdoft Office 2013 (Türkçe)
Zeki Beyin kodu ile
Bu dosyada klasördeki bütün pdf dosyalarından veri alarak sayfalar oluşturmaktadır.

https://www.excel.web.tr/threads/tasinabilir-pdf-to-text-referansi.179025/
Merhaba Halit bey, bu dosyada "Compile error: Can't find project or library" hatası alıyorum sebebi ne olabilir?

Yapmak istediğim form ile falan uğraşmadan (minimum müdahale ile) klasördeki pdf leri excel e aktarabilmek. Diğer konudaki form açarak çevirme işlemleri (sanırım sizin eklediğiniz sonu 4 ve 5 olan dosyalar) sorunsuz çalışırken bu çalışmadı.


Sorunum çözüldü teşekkür ederim. Referenslardan missing olanı kaldırarak çözdüm.
 
Üst