XL 2016 Copier des cellules en image

[Jgral]

Bonjour,

Je cherche à copier une zone de cellule en image ça fonctionne mais l'image est blanche alors que la zone en question est bien rempli

Voici mon bout de code :

Private Sub CommandButton2_Click()
    Copie_Tableau
End Sub
Sub Copie_Tableau()
 With Sheets("Eléments").Range("AF3:AT45")
    .CopyPicture(xlPrinter,xlPicture)
    Sheets("Concepteur étude").ChartObjects.Add(0, 0, .Width, .Height).Chart.Paste
End With
End Sub

Alors que la zone est remplie avec cela :

Auriez vous une idée d'ou vient le problème svp ? Merci par avance.

 

[patricktoulon]

bonjour Jgral
c'est normal avec 2016
quand tu créée le chart il est pas tout a fait dispo tout de suite après la création
sans parler du clipboard qui met plus de temps a digérer le bitmap de la range

un petit exemple prévu pour 2016 et enregistrer la capture de plusieurs range en image et en rafale sur le bureau

Option Explicit
#If VBA7 Then
    Private Declare ptrsafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
#Else
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
#End If
Sub exporte_image()
    Dim plage As Range, chart1 As Object, i As Long, mesplage As Variant, hPicAvail As Long
    With Sheets("Feuil1")
        mesplage = Array("A2:K68", "A69:K180")
        Set chart1 = .ChartObjects.Add(0, 0, 1, 1).Chart
        For i = 0 To UBound(mesplage)
            With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With    'on vide le clipboard entre chaque copie pour tester vraiment le available
            Set plage = .Range(mesplage(i))
            With chart1
                With .Parent
                    .Width = plage.Width: .Height = plage.Height: .Left = plage.Width + 20:
                    plage.CopyPicture
                    Do: DoEvents: hPicAvail = IsClipboardFormatAvailable(14): Loop While hPicAvail = 0    'Or (Timer - T) > 1000
                    .Select
                    Do: DoEvents: Loop Until .Chart.Pictures.Count = 0
                    .Chart.Paste
                    Do: DoEvents: Loop While .Chart.Pictures.Count = 0
                    .Chart.Export Environ("userprofile") & "\Desktop\image_" & i & ".jpg", "jpg"
                    .Chart.Pictures(1).Delete    'on delete a chaque fois l'image collée (important si les plages capturées sont différentes en terme de dimension)
                End With
            End With
        Next
        chart1.Parent.Delete
    End With
End Sub

je l'avais pointé sur un autre forum

 

[Jgral]

Ah OK.

Merci pour ton retour mais étant néophyte en VBA j'avoue ne pas trop capter comment adapter cela à mon besoin qui consiste simplement à coller une image dans un onglet je te met en PJ le fichier source.

 

[patricktoulon]

re
coller quelle image???
tes questions sont très mal formulées
soit plus precis dans tes demandes sinon on s'en sort pas
on sait que tu veux copier une plage en image mais tu veux la mettre ou (dans quel sheets)?????

 

[Jgral]

En gros je veux copier la plage AF3:AT45 de l'onglet Eléments en image dans l'onglet Concepteur étude dans la cellule active avec un léger décalage.

J'espère être plus clair. Désolé.

 

[patricktoulon]

re
bon ben voila pas besoins de chart alors
donc

Sub test()
    Sheets(1).Range("AF3:AT45").CopyPicture xlPrinter, xlPicture
    With Sheets(2): .Activate: .Paste
        With .Shapes(.Shapes.Count)
            .Left = .Left + 10
            .Top = .Top + 3
        End With
    End With
End Sub

change 1 et 2 pour les noms de tes sheets

 

[Jgral]

MErci pour ta réponse j'ai pedant ce temps mis au point cette petite macro :

Sub Macro1()
    Sheets("Eléments").Select
    Range("AF3:AT45").Select
    Selection.Copy
    Sheets("Concepteur étude").Select
    ActiveSheet.Pictures.Paste.Select
    Selection.ShapeRange.IncrementLeft 730.5
    Selection.ShapeRange.IncrementTop 4.5
End Sub

Et ça fonctionne aussi merci en tout cas de ton aide

 

[patricktoulon]

re
pouah!!pouah!!!! les select burk

Sub test()
    Sheets(1).Range("AF3:AT45").CopyPicture xlPrinter, xlBitmap
    With Sheets(2)
         .Paste
        .Pictures(.Pictures.Count).Left = 730.5
        .Pictures(.Pictures.Count).Top = 4.5
    End With
End Sub

tu n'a même pas besoin d’Être sur les sheets concernés pour que ca fonctionne

select pas bien
activate pas bien

 

[youky(BJ)]

Bonsoir à tous,
J'ai rectifié 2 macros,
La macro de patricktoulon plante chez moi
Bruno

Private Sub CheckBox6_Click()
    If CheckBox6 = True Then
        CheckBox6.Font.Bold = True
        'Dimensions et position de la zone de texte
        H = 20 '<-- hauteur
        W = 175 '<-- largeur
        L = ActiveCell.Left + 10  '<-- position horizontale
        T = ActiveCell.Top + 10 '<-- position verticale'Insertion de la zone de texte

        ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, L, T, W, H).Select
        'Selection.Name = "ztxt1" '<-- nom de la zone de texte
        
        'Paramètres de la zone de texte
    
        With Selection
            '.Name = "txt2" '<-- nom de la zone de texte
            .Characters.Text = "Convention sur Parcelle"
            '.HorizontalAlignment = xlCenter '<-- texte centré horizontalement
            .VerticalAlignment = xlCenter '<-- texte centré verticalement
            .ShapeRange.Fill.ForeColor.SchemeColor = 1 '<-- couleur de fond
            .ShapeRange.Line.Weight = 2.5 '<-- épaisseur du cadre
            .ShapeRange.Line.ForeColor.SchemeColor = 7 '<-- couleur du cadre
        End With
        
        'Mise en forme du texte
        With Selection.Font
            .Name = "Calibri" '<-- police
            .Size = 16 '<-- taille
            .Bold = True '<-- mise en gras
            .ColorIndex = 1 '<-- couleur
        End With
        Range("A1").Activate '<-- quitter la sélection de la zone de texte
    Else
        CheckBox6.Font.Bold = False
    End If
End Sub


Private Sub CommandButton2_Click()
ActiveWindow.ScrollRow = Selection.Row 'histoire de voir ce que l'on fait
    Feuil4.Range("AF3:AT45").Copy
    Feuil1.Pictures.Paste.Select
    Selection.ShapeRange.IncrementLeft 730.5
    Selection.ShapeRange.IncrementTop 2
End Sub

 

[patricktoulon]

re
bonsoir @youky(BJ) elle plante ou la macro?

 

[youky(BJ)]

bonsoir,
elle plante ici
Sheets(1).Range("AF3:AT45").CopyPicture xlPrinter, xlBitmap
Bruno

 

[patricktoulon]

re
test avec ca

Sheets(1).Range("AF3:AT45").CopyPicture xlscreen, xlBitmap

 

[youky(BJ)]

NON désolé ! ta macro plante même en mettant les bons noms d'onglet.
Je te laisse tester
Bruno

 

[patricktoulon]

re
ben chez moi ca fonctionne
tu tourne sur quelle version xl

 

[youky(BJ)]

XL 2016
Il refuse la selection af3:at45
Bruno