MS Excel

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ěď >

elninoslov(21.2.2020 23:29)#046002

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: zip

46002_supis-pdf.zip (22kB, staženo 24x)

citovat

Karel-V(24.2.2020 9:15)#046022

Děkuji moc, funguje naprosto perfektněcitovat

Nomi(15.4.2020 13:53)#046429

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

elninoslov(15.4.2020 17:38)#046434

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: png