CAPTURE GRAPHIQUE DU CONTENU D'UN CONTRÔLE DONNÉ DANS UNE IMAGE SAUVÉ SUR DISQUE PUIS DÉCOUPÉE POUR IMPRESSION

Tout d'abord la procédure permettant la capture de l'objet désiré :

    Private Const WM_PRINT As Integer = &H317
    Private Const PRF_CLIENT As Integer = &H4
    Private Const PRF_CHILDREN As Integer = &H10


Public Function PrintControl(ByVal Ctrl As System.Windows.Forms.Control) As System.Drawing.Bitmap
     
        Dim bmp As System.Drawing.Bitmap = Nothing
        Dim gr As System.Drawing.Graphics = Nothing
        Dim hdc As IntPtr = IntPtr.Zero

        Dim newBounds As Rectangle
        newBounds.Location() = New Point(0, 0)
        newBounds.Height = Ctrl.PreferredSize.Height 'important, car PreferredSize contient la taille réelle du contrôle
        newBounds.Width = Ctrl.PreferredSize.Width
        Dim MaRegion As New Region(newBounds)

        Try
            bmp = New System.Drawing.Bitmap(Ctrl.PreferredSize.Width, Ctrl.PreferredSize.Height, Ctrl.CreateGraphics())
            gr = Graphics.FromImage(bmp)

            gr.FillRegion(Brushes.Silver, MaRegion) 'ici, je rempli la totaltilé de l'objet graphic avec la couleur de mon contrôle car sinon, la partie hors écran est rempli par une couleur transparente.

            hdc = gr.GetHdc()
            Dim wParam As IntPtr = hdc
            Dim lParam As IntPtr = New IntPtr(PRF_CLIENT Or PRF_CHILDREN)
            Dim msg As System.Windows.Forms.Message = System.Windows.Forms.Message.Create(Ctrl.Handle, WM_PRINT, wParam, lParam)
            MyBase.WndProc(msg)
        Catch
        Finally
            If Not gr Is Nothing Then
                If hdc <> IntPtr.Zero Then gr.ReleaseHdc(hdc)
                gr.Dispose()
            End If
        End Try
        Return bmp
    End Function

Maintenant, son appel (dans un double clique sur le contrôle, donc sender contient le contrôle au complet):

        Dim h As Integer = sender.PreferredSize.Height
        Dim w As Integer = sender.PreferredSize.Width

        Dim TargetImg As New System.Drawing.Bitmap(w, h)

        TargetImg = PrintControl(sender)

TargetImg va donc contenir l'image du contenu du contrôle. Il suffit de la sauvegarder, ou de l'envoyer, sur l'imprimant ou dans le clipboard, perso je la sauvegarde donc :

        If Dir(MyRepUsers, vbDirectory) = "" Then
            MkDir(MyRepUsers) 'si le répertoire n'existe pas je le crè (MyRepUser contient le chemin de mes documents)
        End If

        TargetImg.Save(MyRepUsers + "\" + sender.name + ".bmp") 'on sauve l'image

Je passe l'image à la procédure de découpage:

    nbToPrint = SplitImage(MyRepUsers + "\" + sender.name + ".bmp")

Que voici :

    Function SplitImage(ByVal path As String) As Integer
        Dim original As New Bitmap(path)
        Dim focusRectangle As New Rectangle()
        Dim destination As Drawing.Bitmap
        Dim w As Integer = 0
        Dim i As Integer = 1
        Dim OK As Boolean = False

        Do While w < original.Width
            focusRectangle.Y = 0
            focusRectangle.Height = original.Height
            focusRectangle.X = w
'pour ma part, je doit découper à des endroits précis pour ne pas couper un contrôle en 2, d'où ce test :
            If Me.chkU.Checked Then
                focusRectangle.Width = 924 + IIf(i = 1, 10, 0)
            Else
                focusRectangle.Width = 809 + IIf(i = 1, 10, 0)
            End If
            If focusRectangle.Width + focusRectangle.X > original.Width Then
                focusRectangle.Width = original.Width - focusRectangle.X
            End If

            'et on découpe
            destination = original.Clone(focusRectangle, Imaging.PixelFormat.DontCare) 'on définit un second BitMap Clonant une partie du 1ere BitMap avec le rectangle
             'et on sauve avec un index
            destination.Save(path.Substring(0, Len(path) - 4) + "_" + i.ToString() + ".bmp")
            If Me.chkU.Checked Then
                w += 924 + IIf(i = 1, 10, 0)
            Else
                w += 809 + IIf(i = 1, 10, 0)
            End If
            i += 1
        Loop

        Return i - 1 'à la sortie, je me retrouve avec i-1 image de mon image principale

    End Function

Il ne reste plus qu'à les imprimer, retour dans le double click du contrôle :

            For i As Integer = 1 To nbToPrint
                If nbToPrint > 1 Then
                    PrepareAndPrint(MyRepUsers + "\" + sender.name + "_" + i.ToString + ".bmp")
                Else
                   'il se peut que l'image n'est pas eut besoin d'être découpée, donc j'imprime l'image principale sans index
                    PrepareAndPrint(MyRepUsers + "\" + sender.name + ".bmp")
                End If
            Next

 et la fonction d'impression :

    Private Sub PrepareAndPrint(ByVal Path As String)
        Dim doc As Printing.PrintDocument = New Printing.PrintDocument
        Dim printer As PrintDialog = New PrintDialog

        doc.DefaultPageSettings.Landscape = True 'rajouté pour ne pas avoir à le choisir dans le dialogue d'impression

        imgBaie = New Bitmap(Path) 'définie en public car PrintPageHandler ce sert de la variable

        AddHandler doc.PrintPage, AddressOf PrintPageHandler
        printer.Document = doc

        Dim response As Windows.Forms.DialogResult = printer.ShowDialog()
        If response = Windows.Forms.DialogResult.OK Then
            doc.Print()
        End If
    End Sub

    Private Sub PrintPageHandler(ByVal sender As Object, ByVal e As System.Drawing.Printing.PrintPageEventArgs)

        Dim canvas As Graphics = e.Graphics
        ' The printer will print the image to whatever bounds are set here (in the next two lines)
        Dim topLeft As Point = New Point(0, 0)
        Dim bottomRight As Point = New Point(e.PageBounds.Width, e.PageBounds.Height)

        ' The rest of the code should not need to be modified
        ' This algorithm makes sure the image scales properly

        Dim pageHeight As Integer = bottomRight.Y - topLeft.Y
        Dim pageWidth As Integer = bottomRight.X - topLeft.X
       
        'sur ces deux ligne, j'ai rajouté +50 car sinon, l'image était trop grande en hauteur et on n'avais pas le bas
        Dim scaleHeight As Single = pageHeight / (imgBaie.Height + 50)
        Dim scaleWidth As Single = pageWidth / (imgBaie.Width + 50)

        ' NewHeight and NewWidth determine the drawing area.
        ' Assume scaleHeight < scaleWidth

        Dim newHeight As Integer = scaleHeight * imgBaie.Height
        Dim newWidth As Integer = scaleHeight * imgBaie.Width

        ' Now check assumption, and correct if wrong

        If scaleWidth < scaleHeight Then
            newHeight = scaleWidth * imgBaie.Height
            newWidth = scaleWidth * imgBaie.Width
        End If

        canvas.DrawImage(imgBaie, 0, 0, newWidth, newHeight)

    End Sub

Et voilà, tout ce code me fait pile poil ce que je voulais.

Télécharger le zip

05 novembre 2007 19:49:50 :

Ajout d'un projet de démonstration