Capture d'image de feuille Excel, rognage, sauvegarde

**Ildenorh** · 12/08/2014, 17h56

Bonjour,

Après trois jours de recherches en français et en anglais et des tentatives infructueuses, je me décide à poster pour chercher une solution.

Je réalise actuellement une sous-macro visant à fabriquer des miniatures de range de feuille Excel pour les insérer dans un userform. Mon premier problème était de pouvoir retravailler les images en les rognant pour ne pas les déformer, ce que j'arrive à faire via des Shapes. Mon second soucis est de pouvoir exporter ces images dans un dossier afin de pouvoir ensuite les appeler dans mes Box images de mon Userform. Ceci j'y arrive aussi, avec des ChartObjects.

Mon soucis est que je n'arrive pas à passer des Shapes aux Chartobjects. Pour être plus précis, J'extrais dans un premier temps l'image avec un range.copypicture, que je colle ensuite sur ma feuille Excel, donc en Shape, pour ensuite la rogner. Je créé ensuite un chartobject dans lequel je copie mon shape. Ca mar nickel pour un oneshot, mais j'ai une boucle sur cette création d'image, et dès la suivante, le chartobject reste sélectionné et le premier copypicture vient se coller dans le chartobject de la première image. Impossible de le déselectionner, j'ai essayé toutes les méthodes trouvées (.chart.deselect / .select sur un range / activechart.deselect...) rien n'y fait. Et mes copypictures attérissent tous dans le premier chartobject.

... Help ?

Code Appelant :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
'--------            ----            ------------    -----    ------------            ----            --------'
 
'-------------------------------------------------------------------------------------------------------------'
'----                       CREATION DES IMAGES DES QUESTIONNAIRES SI NON EXISTANTS                       ----'
'--------            ----            ------------    -----    ------------            ----            --------'
'-------------------------------------------------------------------------------------------------------------'
Public Sub CreerImagesQuestionnaires()
 
'-------------------------------------------------------------------------------------------------------------'
'----                                             Déclaration                                             ----'
'-------------------------------------------------------------------------------------------------------------'
Dim Liste() As String, ListeTraitement() As Boolean, ListeCible() As Range
Dim ImageSize(3) As Integer
Dim Image As ChartObject
Dim CelluleRef As Range
Dim FirstCible As Range, LastCible As Range
Dim FirstLine As Integer, LastLine As Integer, ColumnRef As Integer
Dim i As Integer, j As Integer, k As Integer
 
'-------------------------------------------------------------------------------------------------------------'
'----                                              Processus                                              ----'
'-------------------------------------------------------------------------------------------------------------'
'    I - Définition de la Liste de code des questionnaires
    Set CelluleRef = RechercheFeuille(ThisWorkbook.Worksheets(1), True, "Code")
    FirstLine = CelluleRef.Row + 1
    LastLine = CelluleRef.End(xlDown).Row
    ColumnRef = CelluleRef.Column
    j = 1
    With ThisWorkbook.Worksheets(1)
        ReDim Liste(LastLine - FirstLine + 1)
        ReDim ListeTraitement(3, UBound(Liste))
        ReDim ListeCible(3, UBound(Liste))
        For i = FirstLine To LastLine Step 1
            Liste(j) = .Cells(i, ColumnRef).Value
            For k = 1 To 3 Step 1
                Set FirstCible = ThisWorkbook.Worksheets(CStr(Liste(j) & "." & k)).Cells(1, 1)
                Set LastCible = ThisWorkbook.Worksheets(CStr(Liste(j) & "." & k)) _
                                .Cells(.Cells(i, 8 + k * 2).Value, .Cells(i, 9 + k * 2).Value)
                Set ListeCible(k, j) = Range(FirstCible, LastCible)
            Next k
            j = j + 1
        Next i
    End With
'-------------------------------------------------------------------------------------------------------------'
'   II - Vérification de l'existance ou non des images
    With ThisWorkbook.Worksheets(2)
        For Each Image In .Shapes
            For i = 1 To UBound(Liste) Step 1
                If Left(Image.Name, 5) = Liste(i) Then
                    ListeTraitement(CInt(Right(Image.Name, 1)), i) = True
                End If
            Next i
        Next Image
    Set Image = Nothing
    End With
'-------------------------------------------------------------------------------------------------------------'
'  III - Création des images manquantes
    ImageSize(0) = 150
    ImageSize(1) = 336
    ImageSize(2) = 168
    ImageSize(3) = 168
    For i = 1 To UBound(Liste) Step 1
        For j = 1 To 3 Step 1
            If ListeTraitement(j, i) = False Then
                Set Image = CreerImage(ListeCible(j, i), ThisWorkbook.Worksheets(2), CStr(Liste(i) & "." & j), _
                            ImageSize(j), ImageSize(0), _
                            30 + (j - 1) * 160 + (FRENtoCode(Left(Liste(i), 2)) - 1) * 600, _
                            30 + (CInt(Mid(Liste(i), 3, 3)) - 1) * 350)
            End If
        Next j
    Next i
 
End Sub

Code de la Fonction ou je bloque :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
'--------            ----            ------------    -----    ------------            ----            --------'
 
'-------------------------------------------------------------------------------------------------------------'
'----                        FONCTION DE CREATION D'UNE IMAGE A PARTIR DE CELLULES                        ----'
'--------            ----            ------------    -----    ------------            ----            --------'
'-------------------------------------------------------------------------------------------------------------'
Public Function CreerImage(ByVal Target As Range, ByVal Destination As Worksheet, ByVal TargetedName As String, _
                           ByVal TargetedHeight As Integer, ByVal TargetedWidth As Integer, _
                           ByVal TargetedLeft As Integer, ByVal TargetedTop As Integer) _
                           As ChartObject
'-------------------------------------------------------------------------------------------------------------'
Dim Feuille As Worksheet
Dim Image As Shape
Dim TargetedRatio As Double, Ratio As Double
Dim i As Integer
Dim PointsToCrop As Single
'-------------------------------------------------------------------------------------------------------------'
'    I - Définition des Ratios et repères
    If Not ActiveChart Is Nothing Then
        ActiveChart.Deselect
        Destination.Range(Destination.Cells(1, 1), Destination.Cells(1, 1)).Select
    End If
    Set Feuille = Target.Parent
    TargetedRatio = CDbl(TargetedHeight / TargetedWidth)
    Ratio = CDbl(Target.Height / Target.Width)
    i = 1
    Select Case Ratio
'-------------------------------------------------------------------------------------------------------------'
'   II - Le ratio est identique
        Case Is = TargetedRatio
            Target.CopyPicture
            Destination.Range(destnation.Cells(1, 1), destnation.Cells(1, 1)).Paste
            Set Image = Destination.Shapes(Destination.Shapes.Count)
'-------------------------------------------------------------------------------------------------------------'
'  III - Le ratio est supérieur et induit un élargissement de la Target en colonne
        Case Is > TargetedRatio
            Do
                With Target
                    Set Target = Feuille.Range(Target(1, 1), Target(.Rows.Count, .Columns.Count + i))
                End With
                Ratio = CDbl(Target.Height / Target.Width)
                If Ratio <= TargetedRatio Then
                    Target.CopyPicture
                    Destination.Shapes.Paste
                    Set Image = Destination.Shapes(Destination.Shapes.Count)
                End If
                i = i + 1
            Loop Until Ratio <= TargetedRatio
            With Image
                .Height = TargetedHeight
                .Width = Round(Target.Width * (.Height / Target.Height))
                With .Duplicate
                    .ScaleWidth 1, True
                    PointsToCrop = .Width
                    .Delete
                End With
                PointsToCrop = PointsToCrop * ((.Width - TargetedWidth) / .Width)
                .PictureFormat.CropRight = PointsToCrop
            End With
'-------------------------------------------------------------------------------------------------------------'
'   IV - Le ratio est inférieur et induit un élargissement de la Target en lignes
        Case Is < TargetedRatio
            Do
                With Target
                    Set Target = Feuille.Range(Target(1, 1), Target(.Rows.Count + i, .Columns.Count))
                End With
                Ratio = CDbl(Target.Height / Target.Width)
                If Ratio >= TargetedRatio Then
                    Target.CopyPicture
                    Destination.Paste
                    Set Image = Destination.Shapes(Destination.Shapes.Count)
                End If
                i = i + 1
            Loop Until Ratio >= TargetedRatio
            With Image
                .Width = TargetedWidth
                .Height = Round(Target.Height * (.Width / Target.Width))
                With .Duplicate
                    .ScaleHeight 1, True
                    PointsToCrop = .Height
                    .Delete
                End With
                PointsToCrop = PointsToCrop * ((.Height - TargetedHeight) / .Height)
                .PictureFormat.CropBottom = PointsToCrop
            End With
    End Select
'-------------------------------------------------------------------------------------------------------------'
'    V - Redimentionnement au format attendu
    With Image
        .LockAspectRatio = msoTrue
        .Copy
    End With
    Set CreerImage = Destination.ChartObjects.Add(Left:=TargetedLeft, Width:=TargetedWidth, _
                                                  Top:=TargetedTop, Height:=TargetedHeight)
    With CreerImage
        .Chart.Paste
        .Chart.Deselect
        .Name = TargetedName
    End With
    ActiveChart.Deselect
    Image.Delete
 
End Function

**parmi** · 12/08/2014, 19h19

Bonjour,

Il te faudrait détruire le ChartObject avant réutilisation, si je comprends bien.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
    For i = 1 To UBound(Liste) Step 1
        For j = 1 To 3 Step 1
            If ListeTraitement(j, i) = False Then
                Set Image = CreerImage(ListeCible(j, i), ThisWorkbook.Worksheets(2), CStr(Liste(i) & "." & j), _
                            ImageSize(j), ImageSize(0), _
                            30 + (j - 1) * 160 + (FRENtoCode(Left(Liste(i), 2)) - 1) * 600, _
                            30 + (CInt(Mid(Liste(i), 3, 3)) - 1) * 350)
            End If
        Next j
    Next i

Dans cette boucle, que se passe-t-il avec le ChartObject Image ?

Dans une réponse que j'ai donnée récemment sur un autre site, j'avais écriti ceci.
Tu vois que le TempChart est "deleté" à chaque sauvegarde

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub ShapesToPicture()
    Dim Sh As Worksheet
    Dim ShName As String
    Dim Shp As Shape
    Dim Rng As Range
    Dim TempChart As ChartObject
 
    For Each Sh In Worksheets
        Sh.Activate
        ShName = ActiveSheet.Name
 
        Set Rng = Range("A1:" & Range("L1"))
        Rng.CopyPicture xlScreen, xlPicture
        Set TempChart = ActiveSheet.ChartObjects.Add(0, 0, Rng.Width, Rng.Height)
 
        TempChart.Chart.Paste
        TempChart.Chart.Export "C:\Temp\" & ShName & ".JPG"
        TempChart.Delete
    Next
 
    Set Rng = Nothing
    Set TempChart = Nothing
 
End Sub

**Ildenorh** · 13/08/2014, 10h09

J'espérais bien pouvoir conserver les Charts, afin d'éviter de relancer la procédure de création d'image à chaque démarrage du programme.
Mais je pense avoir trouvé la solution, même si elle va rallonger un peu le temps de calcul.

Je vais faire la phase de création dans une autre Worksheet, puis transférer le chart final dans une worksheet de stockage et nettoyer la première. Je reviens vers vous quand c'est testé.

**Ildenorh** · 18/08/2014, 11h56

J'ai contourné le problème en travaillant sur une autre worksheet que celle sur laquelle je conserve les images sous forme de Chart.

Capture d'image de feuille Excel, rognage, sauvegarde [XL-2007]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager