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
| Sub apercu()
Dim NOM_IMAGE As Variant
Dim mon_sheet As String
Dim ma_selection As String
Dim sh As Worksheet
mon_sheet = ActiveSheet.Name
ma_selection = Selection.Address
Application.DisplayAlerts = False
On Error GoTo suite
Sheets("Graphiquo").Delete'on efface le sheets Graphique si il existe
suite:
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Graphiquo" on ajoute le sheets Graphique
Unload UserForm1
Application.DisplayAlerts = False
Sheets("Graphiquo").Shapes.AddChart.Select on ajoute le graphique
Sheets("Graphiquo").ChartObjects(1).Name = "graphe" 'on nome le graphique
Sheets("Graphiquo").ChartObjects(1).Height = 450 'on lui atribu ses dimentions
Sheets("Graphiquo").ChartObjects(1).Width = 600
ActiveChart.SetSourceData Source:=Sheets(mon_sheet).Range(ma_selection)'on lui atribu les données avec la selection
ActiveChart.ChartType = xlLineMarkers' on lui donne le type
For i = 1 To ActiveChart.SeriesCollection.Count on titre les colections
ActiveChart.SeriesCollection(i).Name = i & "ere/eme base"
Next
UserForm1.show 0
'on copie le graphique dans le clipboard(presse papier)
ActiveSheet.ChartObjects(1).CopyPicture xlScreen, xlBitmap
'prend l'image dans le cliboard
Dim hCopy&: OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H8)
CloseClipboard'on ferme le clipboard
If hCopy = 0 Then Exit Sub si il y a rien on sort de la sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim tIID As GUID, tPICTDEST As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
If Ret Then Exit Sub
With UserForm1
.Height = ActiveSheet.ChartObjects("graphe").Heightl'userform a les meme dimention au depart que le graphique
.Width = ActiveSheet.ChartObjects("graphe").Width
.Top = 0
.Left = 0
.Image1.Picture = iPic on colle le bitmap dans le control image
End With
Sheets("Graphiquo").Visible = False
End Sub
'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Sub Sauve_graphique()
Dim Fname As Variant
' on ouvre la fenetre de dialog pour enregistrer l'image
Fname = Application.GetSaveAsFilename("", "Fichier JPEG (*.JPG),*.JPG,Tous fichiers (*.*),*.*")
'Intercepte l'utilisation du bouton "Annuler" et la croix de fermeture de la fenetre de dialog save as
If VarType(Fname) = vbBoolean Then 'si c 'est false
Set iPic = Nothing 'on vide la variable de ipic
EmptyClipboard ' on vide le presse papier
Unload UserForm1 ' on ferme le userform
CreateObject("Wscript.shell").Popup "cliché annulé ", 1, "" ' le message d'annulation pendant une seconde
Exit Sub 'sortie de la sub
Else
Unload UserForm1 'on ferme le usf
SavePicture iPic, Fname 'on enregistre le cliché
'message de reussite d'enregistrement precisant le chemin et le nom finale de l'image
CreateObject("Wscript.shell").Popup "Le graphique a été enregistré sous le nom de : " & Fname, 1, "Graphique enregistré!!!"
Set iPic = Nothing
EmptyClipboard
End If
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Graphiquo").Delete
End Sub |
graphique instantané au click droit sur selection
Répondre avec citation
Partager