IMPRIMER LE CONTENU D'UN LISTVIEW

Option Explicit

Private Sub Command1_Click()
    '   Appel de la fonction d'impression
    Call ImprimerListView(Me.ListView1, "Ceci est le titre", "Ceci est le sous-titre")
End Sub

Private Sub Form_Load()
    Dim i As Long

    ' Sélection du mode détaillé
    Me.ListView1.View = lvwReport
    ' Création des colonnes
    Me.ListView1.ColumnHeaders.Add 1, , "Colonne 1"
    Me.ListView1.ColumnHeaders.Add 2, , "Colonne 2"
    Me.ListView1.ColumnHeaders.Add 3, , "Colonne 3"    
    '   Remplissage du listview
    For i = 1 To 20
        Me.ListView1.ListItems.Add i, , "Valeur " & CStr(i) & ",1"
        Me.ListView1.ListItems(i).SubItems(1) = "Valeur " & CStr(i) & ",2"
        Me.ListView1.ListItems(i).SubItems(2) = "Valeur " & CStr(i) & ",3"
    Next i

End Sub

Public Sub ImprimerListView(lvwSource As ListView, sTitre As String, sSousTitre As String, Optional ByVal sNomPolice As String = "Arial", Optional ByVal iTaillePolice As Integer = 10)
    On Error GoTo Err_Main
    Const lNB_MAX_ELEM_PAGE As Long = 35
    Dim p As Printer
    Dim lComptElem As Long
    Dim liItem As ListItem
    Dim idxCol As Integer
    Dim lLargTot As Long
    Dim lCurXtmp As Long, lCurYtmp As Long
    Dim lNumPageCour As Long, lNbPages As Long
    Dim sApplication As String, sDate As String
    Dim lNbCarAff As Long
    
    sTitre = UCase(Trim(sTitre))
    sApplication = App.Title & " v" & CStr(App.Major) & "." & CStr(App.Minor) & "." & CStr(App.Revision)
    sDate = Format(Now, "dd/mm/yyyy")
    '   Calcul de la largeur totale des colonnes du listview
    lLargTot = 0
    For idxCol = 1 To lvwSource.ColumnHeaders.Count
        lLargTot = lLargTot + lvwSource.ColumnHeaders(idxCol).Width
    Next
    '   Détermination du nombre de pages, initialisation du numéro de la première page
    lNbPages = Int(lvwSource.ListItems.Count / lNB_MAX_ELEM_PAGE) + 1
    lNumPageCour = 1
        
    '   Instancie l'imprimante cible (imprimante par défaut)
    Set p = Printer

    '   Initialisation de la page
    p.Orientation = vbPRORLandscape
    p.Font = sNomPolice: p.FontSize = iTaillePolice
    p.ScaleHeight = 100: p.ScaleWidth = 100
            
    '   Positionne le titre et le sous-titre de la page
    p.FontBold = True: p.CurrentX = 50 - (p.TextWidth(sTitre) / 2): p.CurrentY = 3: p.Print sTitre
    p.FontBold = False: p.CurrentX = 90: p.CurrentY = 3: p.Print "Page " & CStr(lNumPageCour) & "/" & CStr(lNbPages)
    p.FontBold = False: p.CurrentX = 50 - (p.TextWidth(sSousTitre)) / 2: p.CurrentY = 5: p.Print sSousTitre
    
    '   Positionne les en-têtes de colonnes
    p.CurrentX = 0
    For idxCol = 1 To lvwSource.ColumnHeaders.Count
        lCurXtmp = p.CurrentX
        p.CurrentY = 10
        If lvwSource.ColumnHeaders(idxCol).Width > 0 Then
            p.FontBold = True: p.Print lvwSource.ColumnHeaders(idxCol).Text
        End If
        p.CurrentX = lCurXtmp + (lvwSource.ColumnHeaders(idxCol).Width * 100) / lLargTot
    Next
    p.Line (0, 13)-(100, 13)
    
    '   Ajout des éléments
    p.CurrentY = 14
    lComptElem = 0
    For Each liItem In lvwSource.ListItems
        lCurYtmp = p.CurrentY
        For idxCol = 1 To lvwSource.ColumnHeaders.Count
            If lvwSource.ColumnHeaders(idxCol).Width > 0 Then
                '   Détermine le nombre de caractères affichables
                p.FontBold = False
                lNbCarAff = Int(((lvwSource.ColumnHeaders(idxCol).Width * 100) / lLargTot) / p.TextWidth("A"))
                If idxCol = 1 Then
                    lCurXtmp = 0
                    p.CurrentX = lCurXtmp
                    p.CurrentY = lCurYtmp
                    p.FontBold = False: p.Print Left(liItem.Text, lNbCarAff)
                Else
                    lCurXtmp = lCurXtmp + (lvwSource.ColumnHeaders(idxCol - 1).Width * 100) / lLargTot
                    p.CurrentX = lCurXtmp
                    p.CurrentY = lCurYtmp
                    p.FontBold = False: p.Print Left(liItem.SubItems(idxCol - 1), lNbCarAff)
                End If
            Else
                lCurXtmp = lCurXtmp + (lvwSource.ColumnHeaders(idxCol - 1).Width * 100) / lLargTot
            End If
        Next
        
        '   Incrémente le nombre d'éléments imprimés
        lComptElem = lComptElem + 1
                
        If lComptElem = lNB_MAX_ELEM_PAGE Then
            lComptElem = 0  '   Réinitialise le nomde d'élément ecrits
            p.Line (0, 90)-(100, 90)    '   Trace la ligne de fin de liste
            p.CurrentX = 5: p.CurrentY = 93: p.FontBold = True: p.Print sApplication
            p.CurrentX = 85: p.CurrentY = 93: p.FontBold = False: p.Print sDate
            p.NewPage   '   Change de page
            lNumPageCour = lNumPageCour + 1
            '   Positionne le titre et le sous-titre de la page
            p.FontBold = True: p.CurrentX = 50 - (p.TextWidth(sTitre) / 2): p.CurrentY = 3: p.Print sTitre
            p.FontBold = False: p.CurrentX = 90: p.CurrentY = 3: p.Print "Page " & CStr(lNumPageCour) & "/" & CStr(lNbPages)
            p.FontBold = False: p.CurrentX = 50 - (p.TextWidth(sSousTitre)) / 2: p.CurrentY = 5: p.Print sSousTitre
            '   Positionne les en-têtes de colonnes
            p.CurrentX = 0
            For idxCol = 1 To lvwSource.ColumnHeaders.Count
                lCurXtmp = p.CurrentX
                p.CurrentY = 10
                If lvwSource.ColumnHeaders(idxCol).Width > 0 Then
                    p.FontBold = True
                    p.Print lvwSource.ColumnHeaders(idxCol).Text
                    p.FontBold = False
                End If
                p.CurrentX = lCurXtmp + (lvwSource.ColumnHeaders(idxCol).Width * 100) / lLargTot
            Next
            p.Line (0, 13)-(100, 13)
            p.CurrentY = 14
        End If
    Next liItem
    
    '   Ajoute le pied de page de la dernière page
    p.Line (0, 90)-(100, 90)    '   Trace la ligne de fin de liste
    p.CurrentX = 5: p.CurrentY = 93: p.FontBold = True: p.Print sApplication
    p.CurrentX = 85: p.CurrentY = 93: p.FontBold = False: p.Print sDate
    
    p.EndDoc    '   Lance l'impression du document créé
    
Fin:
    On Error Resume Next
    Set p = Nothing
    Exit Sub
    
Err_Main:
    If Not (p Is Nothing) Then p.KillDoc   'Annule l'impressino du document
    MsgBox Err.Description, vbCritical, App.Title
    Resume Fin

End Sub