Barra de progreso en ejecución de macro

Solicitando su apoyo para adaptar una barra de progreso a la siguiente macro que se ejecuta dando clic a un botón y realiza lo siguiente: primero imprime, luego convierte en pdf la hoja y la guarda en una carpeta y finalmente el pdf lo envía por correo. El proceso tarda aproximadamente 3 minutos desde ya muchas gracias.

Private Sub CommandButton6_Click()
Dim SiNo As String
SiNo = MsgBox("Estás seguro de Imprimir?", vbYesNo + vbQuestion, "CONFIRMA")
If SiNo <> vbYes Then Exit Sub
Worksheets("ReporteSalidas").Select
    Range("A1:N48").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=2, Collate:=True
    Sheets("Menu").Select
    Range("A2").Select
f = Format(Date, ("dd-mm-yy")) 'Formato de Fecha. 'Day(Now()) 'Incluir en nombre
h = VBA. Format(VBA. Time, "hh-mm") 'Formato de hora 'incluir en nombre
Nombre = "Salidas"   'Nombre para el archivo
Ruta = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Control\Reporte de Salidas\"
Worksheets("ReporteSalidas").Select
fila = Range("N65536").End(xlUp).Row
Rango2 = Range(Selection, Cells(fila, 14)).Select  'rango inicio y final selecionado
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Ruta & Nombre & " " & f & " a las " & h, _
quality:=xlQualityStandard, includedocproperties:=True, ignoreprintareas:=False, _
openafterpublish:=False 'False no abre despues de guardado True si
    MsgBox "Se ha guardado a formato PDF en: " & Ruta & Nombre & " " & f & " a las " & h & ".pdf", vbInformation
'Creación del archivo temporal
RutaTemporal = Environ$("temp") & "\"
NombreTemporal = ActiveSheet.Name & Nombre & " " & f & " a las " & h & ".pdf"
RutaCompleta = RutaTemporal & NombreTemporal
On Error GoTo Err
ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=RutaCompleta, _
        quality:=xlQualityStandard, _
        includedocproperties:=True, _
        ignoreprintareas:=False, _
        openafterpublish:=False
'Información para el correo
Set Email = New CDO.Message
    Remitente = Hoja7.Range("B2").Value
    pass = Hoja7.Range("B3").Value
    Destinatario = Hoja7.Range("B4").Value
    Correo_copia = Hoja7.Range("B5").Value
    Oculto_Correo = Hoja7.Range("B6").Value
    Asunto = "Reporte de Ventas"
    Cuerpo = "Hola, Buenas tardes anexo reporte de Ventas"
    Email.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
    Email.Configuration.Fields(cdoSendUsingMethod) = 2
    With Email.Configuration.Fields
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CLng(465)
        .Item("http://schemas.microsoft.com/cdo/" & "configuration/smtpauthenticate") = Abs(1)
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Remitente
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = pass
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    End With
    With Email
        .To = Destinatario
        .From = Remitente
        .Subject = Asunto
        .Cc = Correo_copia
        .BCC = Oculto_Correo
        .TextBody = Cuerpo
        .AddAttachment RutaCompleta
        .Configuration.Fields.Update
        On Error Resume Next
        .Send
    End With
    If Err.Number = 0 Then
        MsgBox "El correo ha sido enviado con éxito", vbInformation, "Confirmación"
    Else
        MsgBox "Se produjo el siguiente error: " & vbNewLine & _
            Err.Description, vbCritical, "Error No. " & Err.Number
    End If
    On Error GoTo 0
    Kill RutaCompleta
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
Exit Sub
Err:
    MsgBox Err.Description, vbCritical + vbOKOnly, Err.Number
End Sub