Impression d'un listview (suite du code de vbfab du 3/10/2002)

Commenter

Contenu du snippet

Le code source de base est l'oeuvre de vbfab (source du 3/10/2002), je n'ai fait que rajouter la possibilite d'imprimer une cellule de ListView en entier (et non les lNbCarAff premiers).

La fonction est a placer dans un module global, puis elle est appelee par:
ImprimerListView(Votre_list_view, "Titre", "Sous-Titre")

Source / Exemple : 


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 = 22
    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, lNbCarCur, lYMax, lY, lElem, lElemMax, lNbCarCut As Long
    Dim sText As String
    
    
    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)
    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
    lYMax = 0
    lY = 0
    For Each liItem In lvwSource.ListItems
        lCurYtmp = p.CurrentY + lYMax
        lYMax = 0
        lY = 0
        lElem = 0
        lElemMax = 0
        For idxCol = 1 To lvwSource.ColumnHeaders.Count
            lY = 0
            If lvwSource.ColumnHeaders(idxCol).Width > 0 Then
                '   Détermine le nombre de caractères affichables
                p.FontBold = False
                lElem = 0
                lNbCarAff = Int(((lvwSource.ColumnHeaders(idxCol).Width * 100) / lLargTot) / p.TextWidth("A"))
                
                If idxCol = 1 Then
                    lCurXtmp = 0
                    p.CurrentX = lCurXtmp
                    p.CurrentY = lCurYtmp
                    sText = liItem.Text
                Else
                    lCurXtmp = lCurXtmp + (lvwSource.ColumnHeaders(idxCol - 1).Width * 100) / lLargTot
                    p.CurrentX = lCurXtmp
                    p.CurrentY = lCurYtmp
                    sText = liItem.SubItems(idxCol - 1)
                End If
                lNbCarCut = lNbCarAff
                If Len(sText) > lNbCarAff Then
                    lNbCarCut = InStrRev(Left(sText, lNbCarAff), " ")
                    If lNbCarCut = 0 Then
                        lNbCarCut = lNbCarAff
                    End If
                End If
                
                p.FontBold = False: p.Print Left(sText, lNbCarCut)
                If Len(sText) > lNbCarCut Then
                        lNbCarCur = lNbCarCut
                        While lNbCarCur < Len(sText)
                            If idxCol < lvwSource.ColumnHeaders.Count Then
                                lY = lY + 1.5
                                p.CurrentY = lCurYtmp + lY
                            End If
                            lElem = lElem + 1
                            p.CurrentX = lCurXtmp
                            If Len(Mid(sText, lNbCarCur)) > lNbCarAff Then
                                lNbCarCut = InStrRev(Mid(sText, lNbCarCur + 1, lNbCarAff), " ")
                                If lNbCarCut = 0 Then
                                    lNbCarCut = lNbCarAff
                                End If
                            End If
                            p.FontBold = False: p.Print Mid(sText, lNbCarCur + 1, lNbCarCut)
                            lNbCarCur = lNbCarCur + lNbCarCut
                        Wend
                End If
                If lYMax < lY Then
                    lYMax = lY
                End If
                If lElemMax < lElem Then
                    lElemMax = lElem
                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 + lElemMax
                
        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)
            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

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.