PDF dosyasından veri alma

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
11,894
Beğeniler
934
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
#1
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
11,894
Beğeniler
934
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
#2
1 nolu mesajdaki dosya güncellendi
 
Katılım
30 Temmuz 2012
Mesajlar
1,684
Beğeniler
73
Excel Vers. ve Dili
2010 - Türkçe 64 Bit
#5
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
11,894
Beğeniler
934
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
#6
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.
 
Katılım
30 Temmuz 2012
Mesajlar
1,684
Beğeniler
73
Excel Vers. ve Dili
2010 - Türkçe 64 Bit
#7
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
11,894
Beğeniler
934
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
#8
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.
 
Katılım
30 Temmuz 2012
Mesajlar
1,684
Beğeniler
73
Excel Vers. ve Dili
2010 - Türkçe 64 Bit
#11
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
 

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
7,442
Beğeniler
673
Excel Vers. ve Dili
32 Bit 2010 - İngilizce
#14
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
11,894
Beğeniler
934
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
#15
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:
Üst