< návrat zpět

MS Excel


Téma: Zjištění počet stran PDF + data souboru rss

Zaslal/a 21.2.2020 15:31

Mohu porosit jestli by mě někdo neporadil co opravit aby makro fungovalo ?
Při spuštění bych měl vybrat adresář, ten makro skontroluje a napíše pod sebe soubory PDF v něm a do dalšího sloupce počet stran - toto mě funguje ale nejde mě tam nějak přidat ještě sloupec s datem uložení toho souboru.

Navíc jestli by při opětovném spuštění nějak označil (barevně, případně dalším sloupcem, nebo jen tučně) nově přidané soubory. Zatím mám řešeno pomocným sloupcem kde jsou předešlé, tak že jen jestli je nějaké jiné řešení.

Makro na zjišťování počtu stran

Sub Počet_stran()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
Set xRg = Range("A1")
Range("A:D").ClearContents
Range("A1:C1").Font.Bold = True
xRg = "Adresa"
xRg.Offset(0, 1) = "Počet stran"
xRg.Offset(0, 2) = "Datum"
I = 2
xStr = ""
Do While xFileName <> ""
Cells(I, 1) = xFileName
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page"
xFileNum = FreeFile
Open (xFdItem & xFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count

'Cells(I, 3) = FileDateTime(xFileName) ' toto nějak opravit aby to do 3 řádku psalo datum souboru

I = I + 1
xFileName = Dir


Loop
Columns("A:B").AutoFit
End If
End Sub
[hr]

Zaslat odpověď >

#046002
elninoslov
Pr.
Sub Pocet_stran()
Dim xStr As String, xFdItem As String, xFileName As String
Dim xFileNum As Long, Count As Long
Dim RegExp As Object, FSO As Object, File As Object
Dim F()

With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> -1 Then MsgBox "Nevybrali ste žiadny adresár": Exit Sub
xFdItem = .SelectedItems(1) & IIf(Right$(.SelectedItems(1), 1) = Application.PathSeparator, "", Application.PathSeparator)
End With

wsOld.UsedRange.ClearContents
With wsCiel.Range("A1:C1").Resize(wsCiel.Cells(Rows.Count, 1).End(xlUp).Row)
wsOld.Range("A1:C1").Resize(.Rows.Count).Value = .Value
.Offset(1, 0).ClearContents
End With

Set FSO = CreateObject("Scripting.FileSystemObject")
Set RegExp = CreateObject("VBscript.RegExp")

With FSO.GetFolder(xFdItem)
For Each File In .Files
xFileName = File.Name
If LCase(FSO.GetExtensionName(xFileName)) = "pdf" Then
Count = Count + 1
ReDim Preserve F(1 To 3, 1 To Count)
F(1, Count) = xFileName
F(3, Count) = File.DateLastModified
With RegExp
.Global = True
.Pattern = "/Type\s*/Page"
xFileNum = FreeFile
Open (xFdItem & xFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
F(2, Count) = .Execute(xStr).Count
End With
End If
Next File
End With

If Count > 0 Then
wsCiel.Range("A2:C2").Resize(Count).Value = Application.Transpose(F)
wsCiel.Columns("A:C").AutoFit
Else
MsgBox "Žiadne súbory PDF"
End If

Set FSO = Nothing: Set RegExp = Nothing: Set File = Nothing
End Sub
Příloha: zip46002_supis-pdf.zip (22kB, staženo 11x)
citovat
#046022
avatar
Děkuji moc, funguje naprosto perfektněcitovat
#046429
avatar
Tak jsem nechal inspirovat a chtěl jsem toto využít, ale zjistil jsem jeden nedostatek a to dost zásadní že to špatně udává počet stránek PDF souborů. Většinou počítá o 1 navíc, ale i někdy více u 32 stran mě to napsalo 38 :(citovat
#046434
elninoslov
Hmm, tak to je problém. Čo si tu tak pozerám rôzne PDF, tak samotná skladba Tag-ov v PDF je problematická, pretože je rôzna podľa verzie PDF (1.5, 1.6, 1.7 ...), obsahu (text, zmiešané, iba obrázok, vektor grafika,...), tvorcu (Word, CorelDraw, ...), oddeľovača Tag-ov a ukončovača skupiny Tag-ov (" ", "", NewLine, ">>",...). A navyše tento Pattern pripočíta aj výskyt "\Type \Pages", čo ale nieje "\Type \Page". Ďalej Tag "/Count" sa niekde rovnako nenachádza.
Múdre hlavy, čo s tým ? Žeby v makre nahradiť všetky Pages, medzery aj konce riadkov, a rozobrať cez Split(xStr "\Type \Pages") ? To bude pomalé, a výsledkom nie som si istý.

EDIT 16.4.2020 0:56 :
Stačí asi iba upraviť Pattern na:
Příloha: png46434_patternreg.png (3kB, staženo 12x)
46434_patternreg.png
citovat
#046440
elninoslov
A ešte celá príloha.
Příloha: zip46440_supis-pdf.zip (23kB, staženo 3x)
citovat
#046441
avatar
Děkuji moc, teda vážně jsi MACHR. A nějak moc ne mi makro nezpomalí tak že za mě palec nahorucitovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura III

Oblíbený formulář Faktura byl vylepšen a rozšířen. Formulář faktura III
Více se dočtete zde.

Aktivní diskuse

VBA vyhledat a zapsat

Stalker • 27.9. 23:02

VBA vyhledat a zapsat

Fantasyk • 27.9. 22:15

VBA vyhledat a zapsat

Stalker • 27.9. 22:04

VBA vyhledat a zapsat

Fantasyk • 27.9. 21:03

vyhledávání s maticí

Fantasyk • 26.9. 11:35

Automatické doplnění

marjankaj • 25.9. 14:27

Automatické doplnění

Dingo • 25.9. 14:25