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
| Option Explicit
'-------------------------Nouveauté--------------------------------------
Private Declare Function GetDC Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" ( _
ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
'-------------------------Fin nouveauté--------------------------------------
'si il n'est pas fait référence à Microsoft Windows Image Acquisition Library v2.0, WIAAut.dll
Private Type FormatImg
'wiaFormatBMP As String
'wiaFormatGIF As String
wiaFormatJPEG As String
'wiaFormatPNG As String
'wiaFormatTIFF As String
End Type
Dim TpImg As FormatImg
Private Sub Form_Load()
'si il n'est pas fait référence à Microsoft Windows Image Acquisition Library v2.0, WIAAut.dll
'TpImg.wiaFormatBMP = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
'TpImg.wiaFormatGIF = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
TpImg.wiaFormatJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
'TpImg.wiaFormatPNG = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
'TpImg.wiaFormatTIFF = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
'-------------------------Nouveauté--------------------------------------
Me.ScaleMode = vbPixels: Picture1.ScaleMode = vbPixels
Me.AutoRedraw = True: Picture1.AutoRedraw = True
Picture1.Visible = False
'-------------------------Fin nouveauté--------------------------------------
'juste pour modifier l'aspect du MSChart par code
MSChart1.Row = 1
MSChart1.RowLabel = "L1"
MSChart1.TitleText = "essais N°1"
MSChart1.SeriesColumn = 2
MSChart1.Data = 55
MSChart1.SeriesColumn = 5
MSChart1.Data = 15
End Sub
Private Sub Command1_Click()
'provisoir, a supprimer quand Ok
Static Num As Integer
On Error Resume Next
Kill App.Path & "\ImgTempo.jpg"
Err.Clear
Num = Num + 1
MSChart1.TitleText = "essais N°" & Num
DoEvents
'-------------- Old -------------------
'MSChart1.EditCopy
'Picture1.Picture = Clipboard.GetData
'-------------------------Nouveauté--------------------------------------
Picture1.Width = MSChart1.Width
Picture1.Height = MSChart1.Height
BitBlt Picture1.hDC, 0, 0, MSChart1.Width, MSChart1.Height, _
GetDC(MSChart1.hwnd), 0, 0, vbSrcCopy
SavePicture Picture1.Image, App.Path & "\ImgTempo.bmp"
'-------------------------Fin nouveauté--------------------------------------
'adaptation du tuto de
'http://silkyroad.developpez.com/VBA/WindowsImageAcquisition/
'Il n'est pas besoin de faire référence à Microsoft Windows Image Acquisition Library v2.0, WIAAut.dll
Dim Img1 As Object
Dim IP 'As ImageProcess
'Création conteneur pour l'image à manipuler
Set Img1 = CreateObject("WIA.ImageFile")
'Chargement de l'image dans le conteneur
Img1.LoadFile (App.Path & "\ImgTempo.bmp")
'Création du gestionnaire de filtre
Set IP = CreateObject("WIA.ImageProcess")
Dim AuFormat As String
AuFormat = TpImg.wiaFormatJPEG
IP.Filters.Add IP.FilterInfos("Convert").FilterID
IP.Filters(1).Properties("FormatID").Value = AuFormat
IP.Filters(1).Properties("Quality").Value = 100
Set Img1 = IP.Apply(Img1)
'sauvegarde de la nouvelle image en .jpg
Img1.SaveFile (App.Path & "\ImgTempo.jpg")
'supprime le fichier temporaire .bmp
Kill App.Path & "\ImgTempo.bmp"
'code pour inclure dans le pdf
'...........
'quand le pdf est OK
'supprime le fichier temporaire .jpg
'Kill App.Path & "\ImgTempo.jpg"
End Sub |
