Stampare file PDF in base a determinati criteri di stampa.

Anonimo

Buon pomeriggio a tutti, ho trovato nello storico delle discussioni del forum il codice sottoriportato, l'ho adattato al mio scopo ed ho fatto alcune prove per testarlo e la stampa dei Pdf nella cartella avviene correttamente.

Ho bisogno del vostro aiuto per poter integrare il codice sottoriportato ( se ciò è possibile) al fine di stampare un determinato nr di files pdf della cartella poiché la mia ne contiene 8500.

Cioè è possibile decidere in base al nr.da stampare ( dal nr. 1 al nr. 100) oppure in base alla lettera dei files poiché tutti i miei files pdf hanno una lettera all'interno del nome, esempio : 111111A.pdf ; 222222B.pdf e cosi via.

Vi ringrazio in anticipo per l'aiuto che vorrete darmi

Ciao Nicola.

Option Explicit

#If VBA7 And Win64 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

#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

#End If

Sub printPDF()

Dim fso As Object ' Scripting.FileSystemObject

Dim fld As Object ' Scripting.Folder

Dim sStartFolder As String

sStartFolder = "C:\Users\xxxxxx\Desktop\Nuova cartella"

Set fso = CreateObject("Scripting.FileSystemObject")

Set fld = fso.GetFolder(sStartFolder)

Call RecursivelyPrint(fld, True)

Set fld = Nothing: Set fso = Nothing

End Sub

Sub RecursivelyPrint(fld As Object, bIncludeSubFolders As Boolean)

Dim fil As Object ' Scripting.File

Dim sfd As Object ' Scripting.Folder

Dim sPdfFile As String

Dim lRet As Long

'--- loop through each file in the folder

For Each fil In fld.Files

sPdfFile = fld.Path & "" & fil.Name

lRet = ShellExecute(0&, "Print", sPdfFile, vbNullString, vbNullString, 1)

If bIncludeSubFolders Then

For Each sfd In fld.SubFolders

Call RecursivelyPrint(sfd, True)

End If

End Sub

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Nicola,

Ciao Norman, tutte le mie prove da circa 1 ora non hanno fruttato nulla.

Non so perché ho provato a mettere come predefinita 3 stampanti diverse ed il problema non cambia.

Il tuo ultimo codice con l'aumento del tempo a 10 secondi funziona benissimo, non ci sono messaggi di errore ma i pdf non vengono stampati.

Eseguo il tuo codice iniziale che mi hai suggerito come diagnostico e tutto va bene.

Per quanto riguarda tutti i messaggi e le immagini relative alle stampanti che tu mi indichi a me non viene visualizzato nulla.

Nemmeno il numero dei files da stampare ( a stampante spenta, faccio click destro ma non si vedono i pdf da stampare), eppure la rotellina ( tipo barra di avanzamento) di Windows che esegue il codice gira , esce il messaggio:

dopodiché la stampa non avviene, nella stampante non viene visualizzato alcun file da stampare.

Stamattina ho provato il codice in un altro ufficcio con pc e stampante diversi e non ho riscontrato alcun problema.

Se per te costa ancora tanto tempo e sacrificio, possiamo pure lasciare andare Norman, non voglio impegnarti ancora per tanto tempo con la mi esigenza.

Decidi tu copsa fare Norman, io ti sono immensamente grato per tutto quello che hai fatto per me.

Non ho alcuna intenzione di rinunciare: l'importante è che tu abbia un codice funzionante!

P.S. eppure Norman come mai quando eseguo questo codice mi stampa tutti i pdf nella cartella, cosa c'è di diverso tra il tuo codice e questo?

Quel codice sfutta un API diverso ma, per gli scopi correnti, equivalente. Esso ha comunque il vantaggio che non sia necessario precisare il percorso o il nome del file AcroRd32.exe, o Acrobat.exe nel caso della versione a pagamento di Adobe.

Comunque, dato che tu hai impiegato con successo questo api, ho adattato di conseguenza il mio codice. Nota, tuttavia, che l'altro codice che hai utilizzato non è equivalente: si limita a stampare tutti i file in una directory e le sue sottodirectory.

Quindi, prova il seguente codice:

'===========>>

Option Explicit

#If VBA7 And Win64 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

#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

#End If

'----------->>

Public Sub Tester()

Dim fso As Object

Dim oFile As Object

Dim oFiles As Object

Dim oFolder As Object

Dim srcWB As Workbook

Dim srcSH As Worksheet

Dim srcRng As Range

Dim arrData As Variant, arrFiles() As Variant, arrHeaders As Variant

Dim i As Long, j As Long, k As Long, m As Long, n As Long, p As Long, q As Long

Dim x As Long, y As Long, z As Long

Dim LRow As Long

Dim iTemp As Long

Dim sPath As String, sStr As String

Dim sFilename As String, sMatch As String

Dim sFile As String

Dim Res As Variant

Dim arr As Variant, arrMatchAlpha() As Variant, arrStampa() As Variant

Dim iCtr As Long, jCtr As Long

Dim LB As Long, UB As Long

Dim iStartChar As Long, iEndChar As Long

Dim blAscending As Boolean, bStampato As Boolean, bMatchAlfa As Boolean

Const srcShName = "Elenco PDF"

Const sNameType As String = ".pdf"

Const sHeaders As String = "File Pdf, Data\Ora Stampato"

Const sPercorsoPdf As String = _

"C:\Users\Nicola\Desktop\Nuova cartella"

On Error GoTo ErrHandler

sStr = Application.PathSeparator

If Right(sPercorsoPdf, 1) <> sStr Then

sPath = sPercorsoPdf & sStr

Else

sPath = sPercorsoPdf

End If

Set srcWB = ThisWorkbook

With srcWB

On Error Resume Next

Set srcSH = .Sheets(srcShName)

On Error GoTo 0

If srcSH Is Nothing Then

arrHeaders = Split(sHeaders, ",")

Set srcSH = .Sheets.Add(Before:=.Sheets(1))

With srcSH

.Name = srcShName

.Range("A1:B1").Value = arrHeaders

End With

End If

End With

With srcSH

LRow = LastRow(srcSH, .Columns("A:A"))

If LRow = 1 Then

Set srcRng = .Range("A2:B" & LRow + 1)

Else

Set srcRng = .Range("A2:B" & LRow)

End If

End With

arrData = srcRng.Value

Set fso = CreateObject("Scripting.FileSystemObject")

Set oFolder = fso.GetFolder(sPath)

Set oFiles = oFolder.Files

For Each oFile In oFiles

With oFile

If .Name Like "*" & sNameType Then

i = i + 1

ReDim Preserve arrFiles(1 To 2, 1 To i)

arrFiles(1, i) = .Name

End If

End With

Next oFile

If i = 0 Then

Call MsgBox(Prompt:="Non ci sono trovati dei file del tipo " _

& sNameType & " nella cartella " & sPercorsoPdf & "!", _

Buttons:=vbCritical, _

Title:="NO PDF FILES FOUND - HELP!!!")

Exit Sub

End If

Res = Application.InputBox( _

Prompt:="Inserisci i numeri/lettere iniziale e finale," _

& " separati da un doppio punto," _

& " ad esempio 1:1000 oppure A:F", _

Default:="1:1000", _

Title:="Pdf da Stampare")

If Res = False Then

Call MsgBox( _

Prompt:="Non hai precisato i file da stampare - riprova!", _

Buttons:=vbCritical, _

Title:="Problema!")

Exit Sub

End If

arr = Split(Res, ":")

Select Case True

Case IsNumeric(arr(0)) And IsNumeric(arr(1))

sMatch = "StampaNumerica"

LB = CLng(arr(0))

UB = CLng(arr(1))

j = UB - LB + 1

Case (arr(0)) Like "[a-z,A-Z]" And arr(1) Like "[a-z,A-Z]"

sMatch = "StampaAlfa"

Case Else

MsgBox "Non hai precisato due numeri o due lettere - Riprova"

Exit Sub

End Select

If sMatch = "StampaNumerica" Then

ReDim Preserve arrStampa(1 To j, 1 To 1)

For k = 1 To i

For m = 1 To UBound(arrData, 1)

If arrFiles(1, k) = arrData(m, 1) Then

bStampato = True

Exit For

End If

Next m

If Not bStampato Then

iCtr = iCtr + 1

arrStampa(iCtr, 1) = arrFiles(1, k)

End If

bStampato = False

If iCtr = j Then

Exit For

End If

Next k

ElseIf sMatch = "StampaAlfa" Then

iStartChar = Asc(UCase(arr(0)))

iEndChar = Asc(UCase(arr(1)))

For y = iStartChar To iEndChar

q = q + 2

ReDim Preserve arrMatchAlpha(1 To q)

arrMatchAlpha(q - 1) = "??????" & Chr(y)

arrMatchAlpha(q) = Chr(y) & "?????"

Next y

For k = 1 To i

For z = LBound(arrMatchAlpha) To UBound(arrMatchAlpha)

If arrFiles(1, k) Like arrMatchAlpha(z) & "*.pdf" Then

For m = 1 To UBound(arrData, 1)

If arrFiles(1, k) = arrData(m, 1) Then

bStampato = True

Exit For

End If

Next m

If Not bStampato Then

iCtr = iCtr + 1

ReDim Preserve arrStampa(1 To iCtr)

arrStampa(iCtr) = arrFiles(1, k)

End If

bStampato = False

If iCtr = j Then

Exit For

End If

Next z

Next k

arrStampa = Application.Transpose(arrStampa)

End If

blAscending = True

If iCtr < j Then

Call MsgBox(Prompt:="Ci sono stati trovati solo " _

& iCtr _

& " file non stampati anziche' i " _

& j _

& " chiesti!", _

Buttons:=vbInformation, _

Title:="Controlla Numero di Documenti")

End If

Call QuickSort(arrStampa, 1, 1, iCtr, blAscending)

For x = LBound(arrStampa) To iCtr

sFilename = sPath & arrStampa(x, 1)

DoEvents

ShellExecute 0, "print", sFilename, vbNullString, vbNullString, 0

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

DoEvents

Next x

ReDim Preserve arrStampa(1 To UBound(arrStampa, 1), 1 To 2)

For i = LBound(arrStampa, 1) To UBound(arrStampa, 1)

arrStampa(i, 2) = Now

Next i

srcSH.Range("A" & LRow + 1).Resize(UBound(arrStampa, 1), 2) _

.Value = arrStampa

Call MsgBox(Prompt:=iCtr & " file sono stati passati alla stampante e " _

& iCtr _

& " record sono aggiunto al foglio " & srcShName, _

Buttons:=vbInformation, _

Title:="REPORT")

XIT:

On Error GoTo 0

Exit Sub

ErrHandler:

MsgBox "Error " & Err.Number _

& " (" & Err.Description & ") in procedure Tester of Module Module6"

End Sub

'<<=========

'--------->>

Public Sub QuickSort(SortArray, col, L, R, bAscending)

'\ Tom Ogilvy: http://goo.gl/ninpZW

'Originally Posted by Jim Rech 10/20/98 Excel.Programming

'Modified to sort on first column of a two dimensional array

'Modified to handle a second dimension greater than 1 (or zero)

'Modified to do Ascending or Descending

Dim i, j, x, y, mm

i = L

j = R

x = SortArray((L + R) / 2, col)

If bAscending Then

While (i <= j)

While (SortArray(i, col) < x And i < R)

i = i + 1

Wend

While (x < SortArray(j, col) And j > L)

j = j - 1

Wend

If (i <= j) Then

For mm = LBound(SortArray, 2) To UBound(SortArray, 2)

y = SortArray(i, mm)

SortArray(i, mm) = SortArray(j, mm)

SortArray(j, mm) = y

Next mm

i = i + 1

j = j - 1

End If

Wend

Else

While (i <= j)

While (SortArray(i, col) > x And i < R)

i = i + 1

Wend

While (x > SortArray(j, col) And j > L)

j = j - 1

Wend

If (i <= j) Then

For mm = LBound(SortArray, 2) To UBound(SortArray, 2)

y = SortArray(i, mm)

SortArray(i, mm) = SortArray(j, mm)

SortArray(j, mm) = y

Next mm

i = i + 1

j = j - 1

End If

Wend

End If

If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)

If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastRow = Rng.Find(What:="*", _

after:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

End Function

'<<=========

===

Regards,

Norman

0 commenti

70 risposte aggiuntive

Anonimo

2015-10-24T18:09:49+00:00

Ciao Norman sono contento che tu non sia affatto infastidito.

Attendo con molto entusiasmo ogni cosa che tu voglia propormi per risolvere al meglio questa mia necessità.

Ti auguro una buona serata ed un felice week end.

Ciao Nicola.
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2015-10-23T21:23:16+00:00

Ciao Nicola,

Stai tranquilla, non sono affatto disturbato!

Tuttavia, al fine di meglio aiutarti e per risolvere questioni in sospeso credo sia desiderabile avere precisione. Per quanto riguarda i nomi dei file, date le possibili implicazioni negative sulla velocità di esecuzione del codice, vorrei qualche tempo per riflettere sui possibili approcci.

Buona serata. Ci sentiamo domani.

===

Regards,

Norman
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2015-10-23T19:54:01+00:00

No, Norman va benissimo come è stato fatto tutto finora, la mia realtà lavorativa si basa sui files con la lettera finale.

Te lo chiedevo solo per curiosità e per poter utilizzare il tuo codice per la stampa dei pdf con InputBox qualora la matricola ( a volte capita che qualche ente esterno mi invia i pdf con la lettera inziale ) avesse la lettera inziale anziché finale.

Ecco in questo caso senza scomodare di nuovo voi esperti, io desideravo poter adattare questo caso variando qualche riferimento nel tuoo codice.

Oppure pensare ( quando ho dei files con la lettera iniziale ) di rinominarli con la lettera finale, magari aprirò un altro trhread con questa esigenza ( cioè creare un codice che mi rinomini i files pdf in base ad una mia indicazione).

Norman va benissimo quello che hai fatto finora, ripeto e per te non deve essere motivo di preoccupazione ( ritieni nullo quello che ho richiesto con questo caso e che ti ha confuso le idee, è come se non te lo avessi chiesto mai).

Non voglio che si ripeta la situazione incresciosa di qualche giorno fa, non ti voglio affatto far lavorare senza nulla, non lo voglio e non lo vorrò mai.

Tranquillizzami dicendomi che ora non ti ho confuso, per favore.

Attendo solo con molto entusiasmo che tu possa aiutarmi con il codice che mi permetta di fare quanto ti ho cortesemente richiesto ai punti precedenti.

Ciao Norman
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2015-10-23T19:37:53+00:00

Cit: o di stampare quelli in cui il settimo carattere rientra nell'intervallo alfabetico specificato dall'utente.

Per poter dire anziché il settimo carattere ma il primo devo cambiare qui qualcosa.

iStartChar = Asc(UCase(arr(0)))

iEndChar = Asc(UCase(arr(1)))

For i = iStartChar To iEndChar

Credo di no.

Avevo pensato di comprendere che i nomi dei file includessero, immutabilmente, un singolo carattere alfabetico, trovato nella settima posizione del nome. Se questo non sia il caso, penso che spetta di definire, in modo chiaro e inequivocabile, la convenzione di denominazione precisa che viene utilizzata.

===

Regards,

Norman
La risposta è stata utile?

0 commenti Nessun commento