![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
Microsoft 365 e Office | Excel | Per la casa | Windows
Una famiglia di software per fogli di calcolo Microsoft con strumenti per l'analisi, la creazione di grafici e la comunicazione dei dati.
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
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