- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,801
- 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
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
Son düzenleme:
