Stampare file PDF in base a determinati criteri di stampa.

Anonimo
2015-10-15T12:57:18+00:00

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)

   Next

   If bIncludeSubFolders Then

     For Each sfd In fld.SubFolders

       Call RecursivelyPrint(sfd, True)

     Next

   End If

 End Sub

Microsoft 365 e Office | Excel | Per la casa | Windows

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
2015-10-28T12:13:44+00:00

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

La risposta è stata utile?

0 commenti

70 risposte aggiuntive

Ordina per: Più utili
Più utili Più recente Meno recente
  1. Anonimo
    2015-10-26T13:26:38+00:00

    Ciao Norman ho eseguito (come tu mi hai indicato) la prova su 5 files come da immagine allegata:

    questo è quanto compare sul foglio di Excel.

    Ma nella realtà Norman non viene stampato alcun file e mi esce questo messaggio:

    Attendo tue circa questa problematica.

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2015-10-26T12:32:48+00:00

    Ciao Nicola,

    P.S. ho dichiarato cosi la variabile sPercorsoPdf

    Dim sPercorsoPdf As String

    Brava, hai fato bene! Le mie dichiarazioni erano diversi perchè i mie percorsi sono diversi e avevo copiato le dichiarazioni da una versione precedente del codice nella mia risposta.

    Per quanto riguarda gli altri errori, io potrei replicarli se la cartella assegnata alla costante sPercorsoPdf  non contenesse alcun file del tipo pdf. Pertanto, controlla che la dicharazione del percorso sia esatta.

    Ho modificato il codice della prima procedura, Tester,  per gestire anche questa possibilità. Allo stesso tempo, ho approfittato per gestire in modo più robusto l'eventuale assenza del foglio Elenco PDF.

    Nel seguente codice, che deve sostituire solo il codice della procedura Tester, le modifiche che ho apportate sono evidenziate in grassetto nel corpo del codice:

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

    Option Explicit

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

    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**"

        Const sPathAdobe As String = _

                   "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"

        On Error GoTo XIT

        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

            Debug.Print x

            DoEvents

            Shell sPathAdobe & " /p /h " & sPath & arrStampa(x, 1), vbHide

            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")

        Exit Sub

    XIT:

        MsgBox "ictr: " & iCtr _

             & vbNewLine _

             & "sFile: " & sFile _

             & vbNewLine _

             & "sFilename:" & sFilename _

             & vbNewLine & vbNewLine _

             & "Dir(sPath & sFilename: " & Dir(sPath & sFilename) _

             & vbNewLine & vbNewLine _

             & "Riga di errore: " & Erl _

             & vbNewLine & "Errore " & Err.Number _

             & " (" & Err.Description & ") in procedura Stampa_A_Richiesta"

    End Sub

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

    In conclusione. Nicola, vorrei caldamente consigliarti di condurre i test iniziali con una selezione di un piccolo numero di file - certamente io non vorrei aspettare mentre 1000 file fossero  stampare per ogni prova!

    ===

    Regards,

    Norman

    La risposta è stata utile?

    0 commenti
  3. Anonimo
    2015-10-26T10:42:20+00:00

    Ciao Norman innanzitutto grazie molte per il lavoro splendido che hai fatto per me.

    Ho inserito il tuoi codice in un modulo  emi compare questo messaggio:

    Norman nella cartella ci sono oltre 8500 files, cosa non va'?

    P.S. ho dichiarato cosi la variabile sPercorsoPdf

    Dim sPercorsoPdf As String

    poiché ricevevo questo messaggio:

    Ciao e buona giornata.

    La risposta è stata utile?

    0 commenti
  4. Anonimo
    2015-10-25T22:03:21+00:00

    Ciao Nicola,

    Per indirzzare tutti i punti e richieste sollevati da te ho rescritto il mio codice da capo.

    Con questo codice, tra l'altro:

    • Si mantiene un record di tutti i file pdf stampati con  i nomi dei file e la loro ora\data di stampa;
    • Si puo stampare un intervallo di file, non precedentemete stampati, sia con un intervallo numerico del tipo 10:50 che un intervallo alfabetico del tipo A:B. In questo ultimo caso tutti i file , non già stampati, saranno stampati se il primo carattere o il settimo carattere del nome del file sia compreso nell'intervallo precisato dall'utente
    • In entrambi i casi, l'intervallo di selezione può iniziare in qualsiasi punto. Se il codice fosse eseguito due volte, con lo stesso intervallo selezionato, i file stampati sarebbero diverse perché l'intervallo si riferisce sempre univocamente a file non stampati.
    • Se il foglio che ricorda la stampa  dei file (Elenco Pdf) non esista già, il codice lo creerebbe.
    • I file saranno passati alla stampate in ordine alfabetico con una pausa tra i file. Se tale pausa non fosse prevista, Adobe modificherebbe la posizione del file casuali. Nei miei test, riducendo la pausa a meno di 3 secondi causava problemi. A seconda della velocità e la memoria della stampante, potrebbe essere possibile ridurre questo intervallo. Tuttavia, per stampare 8.500 file pdf, ci sarà sempre bisogno di un tempo non trascurabile. In ogni modo, come suggerito in un altro dei tuoi thread, credo tale codice possa sempre essere programmato per essere eseguita, senza sorveglianza, in tempi morti,

    In un modulo standard, incolla:

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

    Option Explicit

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

    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

        Dim 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 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 sPercorso As String = _

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

        Const sPathAdobe As String = _

              "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"

        On Error GoTo XIT

        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)

            End If

        End With

        If Not srcRng Is Nothing Then

            arrData = srcRng.Value

        End If

        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

        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

            Debug.Print x

            DoEvents

            Shell sPathAdobe & " /p /h " & sPath & arrStampa(x, 1), vbHide

            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")

        Exit Sub

    XIT:

        MsgBox "ictr: " & iCtr _

             & vbNewLine _

             & "sFile: " & sFile _

             & vbNewLine _

             & "sFilename:" & sFilename _

             & vbNewLine & vbNewLine _

             & "Dir(sPath & sFilename: " & Dir(sPath & sFilename) _

             & vbNewLine & vbNewLine _

             & "Riga di errore: " & Erl _

             & vbNewLine & "Errore " & Err.Number _

             & " (" & Err.Description & ") in procedura Stampa_A_Richiesta"

    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

    La risposta è stata utile?

    0 commenti