Inserire barra che avanza in progressione

Question

Ciao a tutti,

Chiedo il vostro aiuto per capire dove inserire nel codice che riporto di seguito le istruzioni che mi permettono di capire a che punto sta la creazione dei vari file in formato Pdf. 

Tramite questo sito ho trovato le istruzioni che mi hanno permesso di inserire una barra che avanza in progressione. 

Fino a quel punto tutto semplice, la parte difficile è capire dove inserire quella parte di codice che mi permette di seguire la creazione dei file dal primo all'ultimo. Confido nel vostro aiuto per capire mediante barra di avanzamento, a che punto si trova la creazione dei vari file visto che può durare alcuni minuti. Questo è il codice che uso:

Public Sub ConvertiModuliPdf()

   Dim SH As Worksheet

   Dim SHC As Worksheet

   Dim srcRng As Range, destRng As Range, rCell As Range

   Dim lRow As Long, lRisposta As Long

   Dim sNome As String, sPath As String

   sPath = ThisWorkbook.Path & Application.PathSeparator

   With ThisWorkbook

       Set SH = .Worksheets("Foglio1")

       Set SHC = .Worksheets("Foglio2")

   End With

   Set destRng = SH.Range("C2")

   SH.Protect Password:=sPassWord, _

            UserInterfaceOnly:=True

   Application.ScreenUpdating = False

   lRisposta = MsgBox(Prompt:= _

                      "Sei proprio sicuro di creare tutte le Cartoline?." _

                      & vbNewLine _

                      & "Se premi Si, saranno create tutte le cartoline.", _

                      Buttons:=vbYesNo + vbCritical, _

                      Title:="Avvertimento!")

   If lRisposta = vbYes Then

      With SHC

         lRow = .Range("A" & Rows.Count).End(xlUp).Row

         Set srcRng = .Range("A3:A" & lRow)

      End With

    For Each rCell In srcRng.Cells

            With rCell

            If .Value <> vbNullString Then

             destRng.Value = rCell.Value

             sNome = destRng.Value & ".pdf"

             SH.ExportAsFixedFormat Type:=xlTypePDF, _

                           FileName:=sPath & sNome, _

                           Quality:=xlQualityStandard, _

                           IncludeDocProperties:=True, _

                           IgnorePrintAreas:=False, _

                           OpenAfterPublish:=False

            End If

         End With

       Next rCell

   Else

        Exit Sub

   End If 

   Application.ScreenUpdating = True

XIT:

End Sub

Answer 1

Ciao Geacs,

In un modulo standard, incolla il seguente codice:

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

Option Explicit

'Option Private Module

Public Const GWL_STYLE = -16

Public Const WS_CAPTION = &HC00000

#If VBA7 Then

    Public Declare PtrSafe Function GetWindowLong _

           Lib "user32" Alias "GetWindowLongA" ( _

           ByVal hWnd As Long, _

           ByVal nIndex As Long) As Long

    Public Declare PtrSafe Function SetWindowLong _

           Lib "user32" Alias "SetWindowLongA" ( _

           ByVal hWnd As Long, _

           ByVal nIndex As Long, _

           ByVal dwNewLong As Long) As Long

    Public Declare PtrSafe Function DrawMenuBar _

           Lib "user32" ( _

           ByVal hWnd As Long) As Long

    Public Declare PtrSafe Function FindWindowA _

           Lib "user32" (ByVal lpClassName As String, _

                         ByVal lpWindowName As String) As Long

#Else

    Public Declare Function GetWindowLong _

                         Lib "user32" Alias "GetWindowLongA" ( _

                             ByVal hWnd As Long, _

                             ByVal nIndex As Long) As Long

    Public Declare Function SetWindowLong _

                         Lib "user32" Alias "SetWindowLongA" ( _

                             ByVal hWnd As Long, _

                             ByVal nIndex As Long, _

                             ByVal dwNewLong As Long) As Long

    Public Declare Function DrawMenuBar _

                         Lib "user32" ( _

                             ByVal hWnd As Long) As Long

    Public Declare Function FindWindowA _

                         Lib "user32" (ByVal lpClassName As String, _

                                       ByVal lpWindowName As String) As Long

#End If

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

Public Sub HideTitleBar(frm As Object)

    Dim lngWindow As Long

    Dim lFrmHdl As Long

    lFrmHdl = FindWindowA(vbNullString, "Userform1")

    lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)

    lngWindow = lngWindow And (Not WS_CAPTION)

    Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)

    Call DrawMenuBar(lFrmHdl)

End Sub

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

In un altro modulo standard, incolla qualcosa del genere:

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

Option Explicit

Const sPassword As String = "Pippo"      '<<=== Modifica

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

Public Sub ConvertiModuliPdf()

    Dim SH As Worksheet

    Dim SHC As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim lRow As Long, lRisposta As Long

    Dim sNome As String, sPath As String

    Dim i As Long, iCtr As Long, iTotal As Long

    Dim pctdone As Double

    sPath = ThisWorkbook.Path & Application.PathSeparator

    With ThisWorkbook

        Set SH = .Worksheets("Foglio1")

        Set SHC = .Worksheets("Foglio2")

    End With

    Set destRng = SH.Range("C2")

    SH.Protect Password:=sPassword, _

               UserInterfaceOnly:=True

    On Error GoTo XIT

    Application.ScreenUpdating = False

    lRisposta = MsgBox(Prompt:= _

                       "Sei proprio sicuro di creare tutte le Cartoline?." _

                       & vbNewLine _

                       & "Se premi Si, saranno create tutte le cartoline.", _

                       Buttons:=vbYesNo + vbCritical, _

                       Title:="Avvertimento!")

    If lRisposta = vbYes Then

        With SHC

            lRow = .Range("A" & Rows.Count).End(xlUp).Row

            Set srcRng = .Range("A3:A" & lRow)

        End With

        ufProgress.LabelProgress.Width = 0

        ufProgress.Show vbModeless

        iTotal = srcRng.Cells.Count

        For i = 1 To iTotal

            With srcRng.Cells(i)

                If .Value <> vbNullString Then

                    pctdone = i / iTotal

                    With ufProgress

                        .LabelCaption.Caption = "svilupando file " & i & " di " & iTotal

                        .LabelProgress.Width = pctdone * (.frameProgress.Width)

                    End With

                    DoEvents

                    destRng.Value = .Value

                    sNome = destRng.Value & ".pdf"

                    SH.ExportAsFixedFormat _

                            Type:=xlTypePDF, _

                            Filename:=sPath & sNome, _

                            Quality:=xlQualityStandard, _

                            IncludeDocProperties:=True, _

                            IgnorePrintAreas:=False, _

                            OpenAfterPublish:=False

                    If i = iTotal Then Unload ufProgress

                End If

            End With

        Next i

    Else

        Exit Sub

    End If

XIT:

    Application.ScreenUpdating = True

End Sub

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

Potresti scaricare il mio file di prova Geacs20190703.xlsm

===

Regards,

Norman

Answer 2

Ciao Geacs,

Tutto straordinariamente piacevole a vedersi e perfetto nell’esecuzione. Mi lasci senza parole, prima di dare fastidio ho fatto un milione di prove ma nulla. Ancora grazie per l’aiuto.

Ti ringrazio per il cortese riscontro.

Alla prossima.

===

Regards,

Norman

Answer 3

Ciao Norman,

Tutto straordinariamente piacevole a vedersi e perfetto nell’esecuzione. Mi lasci senza parole, prima di dare fastidio ho fatto un milione di prove ma nulla. Ancora grazie per l’aiuto.