[VB]Problème affichage image dans IE6

**flogreg** · 13/02/2006, 17h26

Bonjour,
J'ai créé un programme qui me permet de créer des graphiques, de les sauvegarder en bitmap et de les convertir en .gif pour que ca soit moins lourd. Ensuite j'affiche ces graphs sur l'intranet. Tout fonctionnait bien jusqu'à que Mr Microsoft sorte un patch de sécurité (KB905915) qui empeche ces images d'etre affichées. Le problème vient bien du patch, j'en suis sur. Alors je suis allé voir Madame sécurité et je lui ai demandé de bien voulloir supprimer ce patch de tout les PC mais elle a refusé par mesure de sécurité. Il faut donc que je revois la classe que j'utilisais pour convertir les bitmap en .gif.
Nota :
- les bitmaps s'affichent bien mais sont lourds et moins beau puisque les gif sont en transparent.
- Je n'ai pas développé la classe qui converti en gif. Je l'ai trouvé sur internet dans une appli qui ne faisait que ca.

Voici ma classe (GIF.cls), si quelqu'un pouvait me dire ce qui ne va pas car là, je ne comprend plus rien :

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
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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
 
Option Explicit
 
 
Private Type RGBTRIPLE
    rgbRed As Byte
    rgbGreen As Byte
    rgbBlue As Byte
End Type
 
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
 
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
 
Private Type BITMAPINFO256
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 255) As RGBQUAD
End Type
 
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
 
Private Const BI_RGB = 0&
 
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName _
    As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, _
    lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject 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
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As _
    Long, ByVal nNumScans As Long, lpBits As Any, lpbi As BITMAPINFO256, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBSection256 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDc As Long, pBitmapInfo _
    As BITMAPINFO256, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Const DIB_RGB_COLORS = 0
 
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) _
    As Long
 
 
Private Type GifScreenDescriptor
    logical_screen_width As Integer
    logical_screen_height As Integer
    Flags As Byte
    background_color_index As Byte
    pixel_aspect_ratio As Byte
End Type
 
Private Type GifImageDescriptor
    Left As Integer
    Top As Integer
    Width As Integer
    Height As Integer
    Format As Byte
End Type
 
Private Type CONTROLBLOCK
    Blocksize As Byte
    Flags As Byte
    Delay As Integer
    TransParent_Color As Byte
    Terminator As Byte
End Type
Private Const GIF89a = "GIF89a"
Private Const CtrlIntro As Byte = &H21
Private Const CtrlLabel As Byte = &HF9
 
 
Const GIF87a = "GIF87a"
 
Const GifTerminator As Byte = &H3B
Const ImageSeparator As Byte = &H2C
Const CHAR_BIT = 8
Const CodeSize As Byte = 9
Const ClearCode = 256
Const EndCode  As Integer = 257
Const FirstCode = 258
Const LastCode As Integer = 511
Const MAX_CODE = LastCode - FirstCode
 
Private colTable As New Collection
Private fn As Integer
Private gifPalette(0 To 255) As RGBTRIPLE
Private bit_position As Integer
Private code_count As Integer
Private data_buffer(255) As Byte
Private aPower2(31) As Long
Private picWidth As Long
Private picHeight As Long
Private IsBusy As Boolean
Public Event Progress(ByVal Percents As Integer)
 
 
Public Function SaveGIF(ByVal pic As StdPicture, ByVal sFileName As String, Optional hDc As Long = 0, Optional _
        UseTrans As Boolean = False, Optional ByVal TransColor As Long = 0) As Boolean
    If IsBusy Then Exit Function
  Dim scr As GifScreenDescriptor
  Dim im As GifImageDescriptor
  Dim bi As BITMAPINFO256
  Dim bm As BITMAP
  Dim hDCScn As Long
  Dim OldObj As Long
  Dim Src_hDc As Long
  Dim hDib256 As Long
  Dim hDC256 As Long
  Dim OldObj256 As Long
  Dim buf() As Byte
  Dim Data As Byte
  Dim TransIndex As Byte
  Dim i As Long
  Dim J As Long
  Dim clr As Long
  Dim bFound As Boolean
  Dim intCode As Integer
  Dim nCount   As Integer
  Dim sPrefix As String
  Dim sByte As String
  Dim tempPic As StdPicture
    IsBusy = True
 
    Call GetObjectAPI(pic, Len(bm), bm)
    picWidth = bm.bmWidth
    picHeight = bm.bmHeight
    ReDim buf(CLng(((picWidth + 3) \ 4) * 4), picHeight) As Byte
 
    hDCScn = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    hDC256 = CreateCompatibleDC(hDCScn)
    If hDc = 0 Then
        Src_hDc = CreateCompatibleDC(hDCScn)
        OldObj = SelectObject(Src_hDc, pic)
    Else
        Src_hDc = hDc
    End If
    DeleteDC hDCScn
 
 
    If bm.bmBitsPixel <> 8 Then hDib256 = CreateDib256(hDC256, bi)
    If hDib256 <> 0 Then
        OldObj256 = SelectObject(hDC256, hDib256)
        Call BitBlt(hDC256, 0, 0, picWidth, picHeight, Src_hDc, 0, 0, vbSrcCopy)
        For i = 0 To picHeight - 1
            Call GetDIBits(hDC256, hDib256, i, 1, buf(0, picHeight - i), bi, 0)
        Next
    Else
        With bi.bmiHeader
            .biSize = Len(bi.bmiHeader)
            .biWidth = picWidth
            .biHeight = picHeight
            .biPlanes = 1
            .biBitCount = 8
            .biCompression = BI_RGB
        End With
        For i = 0 To picHeight - 1
            Call GetDIBits(Src_hDc, pic, i, 1, buf(0, picHeight - i), bi, 0)
        Next
    End If
 
    For i = 0 To 255
        gifPalette(i).rgbBlue = bi.bmiColors(i).rgbBlue
        gifPalette(i).rgbGreen = bi.bmiColors(i).rgbGreen
        gifPalette(i).rgbRed = bi.bmiColors(i).rgbRed
        If Not bFound Then
            clr = RGB(gifPalette(i).rgbRed, gifPalette(i).rgbGreen, gifPalette(i).rgbBlue)
            If clr = TransColor Then
                TransIndex = i: bFound = True
            End If
        End If
    Next
 
    scr.background_color_index = 0
    scr.Flags = &HF7
    scr.pixel_aspect_ratio = 0
 
    im.Format = &H7
    im.Height = picHeight
    im.Width = picWidth
 
    If FileExists(sFileName) Then
        SetAttr sFileName, vbNormal
 
        Kill sFileName
    End If
    fn = FreeFile
    Open sFileName For Binary As fn
 
    If UseTrans = True Then
        Put #fn, , GIF89a
    Else
        Put #fn, , GIF87a
    End If
    Put #fn, , scr
    Put #fn, , gifPalette
 
    If UseTrans = True Then
        Put #fn, , CtrlIntro
        Put #fn, , CtrlLabel
        Dim cb As CONTROLBLOCK
        cb.Blocksize = 4
        cb.Flags = 9
        cb.Delay = 0
        cb.TransParent_Color = TransIndex
        cb.Terminator = 0
        Put #fn, , cb
    End If
    Put #fn, , ImageSeparator
    Put #fn, , im
    Data = CodeSize - 1
    Put #fn, , Data
    data_buffer(0) = 0
    bit_position = CHAR_BIT
 
    For i = 1 To picHeight
        Reinitialize
        sPrefix = ""
        intCode = buf(0, i)
        On Error Resume Next
        For J = 1 To picWidth - 1
            sByte = MyFormat(buf(J, i))
            sPrefix = sPrefix & sByte
            intCode = colTable(sPrefix)
            If Err <> 0 Then
                nCount = colTable.count
                If nCount = MAX_CODE Then Reinitialize
                colTable.Add nCount + FirstCode, sPrefix
                OutputBits intCode, CodeSize
                sPrefix = sByte
                intCode = buf(J, i)
                Err.Clear
            End If
        Next
        OutputBits intCode, CodeSize
        If i Mod 10 = 0 Then
            RaiseEvent Progress(i * 100 / picHeight)
            DoEvents
        End If
    Next
    OutputCode (EndCode)
    For i = 0 To data_buffer(0)
        Put #fn, , data_buffer(i)
    Next
    Data = 0
    Put #fn, , Data
    Put #fn, , GifTerminator
    Close fn
    Erase buf
    If hDc = 0 Then
        SelectObject Src_hDc, OldObj
        DeleteDC Src_hDc
    End If
    SelectObject hDC256, OldObj256
    DeleteObject hDib256
    DeleteDC hDC256
    SaveGIF = True
    IsBusy = False
End Function
 
Private Sub OutputBits(Value As Integer, count As Integer)
  Dim i As Integer
  Dim bit As Integer
    Do While i < count
        If bit_position = CHAR_BIT Then
            If data_buffer(0) = 255 Then
                Put #fn, , data_buffer
                data_buffer(0) = 1
            Else
                data_buffer(0) = data_buffer(0) + 1
            End If
            data_buffer(data_buffer(0)) = 0
            bit_position = 0
        End If
        bit = Sgn(Power2(i) And Value)
        If bit > 0 Then data_buffer(data_buffer(0)) = Power2(bit_position) Or data_buffer(data_buffer(0))
        i = i + 1: bit_position = bit_position + 1
    Loop
End Sub
 
Private Sub OutputCode(code As Integer)
    code_count = code_count + 1
    If code_count > LastCode Then
        code_count = FirstCode
        Call OutputBits(ClearCode, CodeSize)
        ClearTable
    End If
    Call OutputBits(code, CodeSize)
End Sub
 
Private Sub ClearTable()
    Set colTable = Nothing
    Set colTable = New Collection
End Sub
 
Private Sub Reinitialize()
    ClearTable
    Call OutputBits(ClearCode, CodeSize)
End Sub
 
Private Function FileExists(ByVal strPathName As String) As Boolean
  Dim af As Long
    af = GetFileAttributes(strPathName)
    FileExists = (af <> -1)
End Function
 
Private Function Power2(ByVal i As Integer) As Long
    If aPower2(0) = 0 Then
        aPower2(0) = &H1&
        aPower2(1) = &H2&
        aPower2(2) = &H4&
        aPower2(3) = &H8&
        aPower2(4) = &H10&
        aPower2(5) = &H20&
        aPower2(6) = &H40&
        aPower2(7) = &H80&
        aPower2(8) = &H100&
        aPower2(9) = &H200&
        aPower2(10) = &H400&
        aPower2(11) = &H800&
        aPower2(12) = &H1000&
        aPower2(13) = &H2000&
        aPower2(14) = &H4000&
        aPower2(15) = &H8000&
        aPower2(16) = &H10000
        aPower2(17) = &H20000
        aPower2(18) = &H40000
        aPower2(19) = &H80000
        aPower2(20) = &H100000
        aPower2(21) = &H200000
        aPower2(22) = &H400000
        aPower2(23) = &H800000
        aPower2(24) = &H1000000
        aPower2(25) = &H2000000
        aPower2(26) = &H4000000
        aPower2(27) = &H8000000
        aPower2(28) = &H10000000
        aPower2(29) = &H20000000
        aPower2(30) = &H40000000
        aPower2(31) = &H80000000
    End If
    Power2 = aPower2(i)
End Function
 
Private Function MyFormat(ByVal s As String) As String
    MyFormat = Right$("00" & s, 3)
End Function
 
Private Function CreateDib256(ByVal h_Dc As Long, bi As BITMAPINFO256) As Long
  Dim lScanSize As Long
  Dim lptr As Long
  Dim lIndex As Long
  Dim r As Long
  Dim g As Long
  Dim b As Long
  Dim rA As Long
  Dim gA As Long
  Dim bA As Long
    With bi.bmiHeader
        .biSize = Len(bi.bmiHeader)
        .biWidth = picWidth
        .biHeight = picHeight
        .biPlanes = 1
        .biBitCount = 8
        .biCompression = BI_RGB
        lScanSize = (picWidth + picWidth Mod 4)
        .biSizeImage = lScanSize * picHeight
    End With
 
    For b = 0 To &H100 Step &H40
        If b = &H100 Then
            bA = b - 1
        Else
            bA = b
        End If
        For g = 0 To &H100 Step &H40
            If g = &H100 Then
                gA = g - 1
            Else
                gA = g
            End If
            For r = 0 To &H100 Step &H40
                If r = &H100 Then
                    rA = r - 1
                Else
                    rA = r
                End If
                With bi.bmiColors(lIndex)
                    .rgbRed = rA: .rgbGreen = gA: .rgbBlue = bA
                End With
                lIndex = lIndex + 1
            Next r
        Next g
    Next b
    CreateDib256 = CreateDIBSection256(h_Dc, bi, DIB_RGB_COLORS, lptr, 0, 0)
End Function

et dans mon programme je fais ceci :

Code :

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

1
2
3
 
        Set cGif = New GIF
        cGif.SaveGIF Picture2.Picture, filejpg, Picture2.hDc, 1, Picture2.Point(0, 0)

J'utilise aussi cette classe (CDibSection.cls) :

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
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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
 
Option Explicit
 
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDc As Long, pBitmapInfo As BITMAPINFO, ByVal un As _
    Long, lplpVoid As Long, ByVal handle As Long, ByVal dw 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
Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, _
    lpObject As Any) As Long
 
 
Private m_hDIb As Long
 
Private m_hBmpOld As Long
 
Private m_hDC As Long
 
Private m_lPtr As Long
 
Private m_tBI As BITMAPINFO
 
Public Property Get BytesPerScanLine() As Long
 
    BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property
 
Public Property Get Width() As Long
    Width = m_tBI.bmiHeader.biWidth
End Property
 
Public Property Get Height() As Long
    Height = m_tBI.bmiHeader.biHeight
End Property
 
Public Sub LoadPictureBlt(ByVal lhDC As Long, Optional ByVal lSrcLeft As Long = 0, Optional ByVal lSrcTop _
        As Long = 0, Optional ByVal lSrcWidth As Long = -1, Optional ByVal lSrcHeight As Long = -1, Optional ByVal _
        eRop As RasterOpConstants = vbSrcCopy)
    If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
    If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
    BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lhDC, lSrcLeft, lSrcTop, eRop
End Sub
 
Public Property Get DIBSectionBitsPtr() As Long
    DIBSectionBitsPtr = m_lPtr
End Property
 
Public Sub ClearUp()
    If (m_hDC <> 0) Then
        If (m_hDIb <> 0) Then
            SelectObject m_hDC, m_hBmpOld
            DeleteObject m_hDIb
        End If
        DeleteObject m_hDC
    End If
    m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
End Sub
 
Public Function CreateFromPicture(ByRef picThis As StdPicture)
  Dim lhDC As Long
  Dim lhDCDesktop As Long
  Dim lhBmpOld As Long
  Dim tBMP As BITMAP
 
    GetObjectAPI picThis.handle, Len(tBMP), tBMP
    If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
        lhDCDesktop = GetDC(GetDesktopWindow())
        If (lhDCDesktop <> 0) Then
            lhDC = CreateCompatibleDC(lhDCDesktop)
            DeleteDC lhDCDesktop
            If (lhDC <> 0) Then
                lhBmpOld = SelectObject(lhDC, picThis.handle)
                LoadPictureBlt lhDC
                SelectObject lhDC, lhBmpOld
                DeleteObject lhDC
            End If
        End If
    End If
End Function
 
Public Function CreateDIB(ByVal lhDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByRef hDib As Long _
        ) As Boolean
    With m_tBI.bmiHeader
        .biSize = Len(m_tBI.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    hDib = CreateDIBSection(lhDC, m_tBI, DIB_RGB_COLORS, m_lPtr, 0, 0)
    CreateDIB = (hDib <> 0)
End Function
 
Public Function Create(ByVal lWidth As Long, ByVal lHeight As Long) As Boolean
    ClearUp
    m_hDC = CreateCompatibleDC(0)
    If (m_hDC <> 0) Then
        If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
            m_hBmpOld = SelectObject(m_hDC, m_hDIb)
            Create = True
        Else
            DeleteObject m_hDC
            m_hDC = 0
        End If
    End If
End Function

**flogreg** · 20/02/2006, 18h41

J'ai trouvé une autre solution. J'utilise le composant BMP2GIF.ocx

[VB]Problème affichage image dans IE6

VB 6 et antérieur

Discussions similaires

Partager

Partager