Code:
'Special thanks to jmsrickland from www.VBForums.com
Option Explicit
Option Base 0
Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y 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 Enum GifType
GIF87A = 0
GIF89A = 1
End Enum
Private Type LogicalScreenDescriptor
GifWidth As Long
GifHeight As Long
GlobalColorSize As Long
SortFlag As Long
ColorResolution As Long
GlobalColorFlag As Long
BackgroundColor As Long
PixelRadio As Long
End Type
Private Type GraphicControl
Disposal As Long
Delay As Long
TransparentColorIndex As Long
UserInput As Long
TransparentFlag As Long
End Type
Private Type ImageDescription
FrameLeft As Long
FrameTop As Long
FrameWidth As Long
FrameHeight As Long
End Type
Private Type Frame
GCGraphicControl As GraphicControl
IDImageDescription As ImageDescription
End Type
Dim fraFrame() As Frame
Public Function LoadGifFile(strFileName As String, aimg As Variant) As Long
Dim GifHeader As GifType
Dim strLogicalScreenDescription As String
Dim LSDLogicalScreenDescription As LogicalScreenDescriptor
'Dim GCGraficControl As GraphicControl
'Dim IDImageDescription As ImageDescription
Dim strGifHeader As String
Dim strFrame As String
Dim fNum As Integer
Dim FileBuffer As String
Dim PictureBuffer As String
Dim PackedField As String
Dim FirstFrame As Long
Dim FrameEnds As Long
Dim ActualFrame As Long
Dim i As Integer
'On Error Resume Next
'Test if the file exists
If Dir$(strFileName) = "" Or strFileName = "" Then
MsgBox "File " & strFileName & " not found", vbCritical
Exit Function
End If
'Put all file info to a variable
fNum = FreeFile
Open strFileName For Binary Access Read As fNum
FileBuffer = String(LOF(fNum), Chr(0))
Get #fNum, , FileBuffer
Close fNum
'FileBuffer = Trim(FileBuffer)
'unload all pictureboxes\images
For i = 1 To aimg.Count - 1
Unload aimg(i)
Next i
aimg(0).Visible = True
'Gif Header
strGifHeader = Left$(FileBuffer, 6)
If strGifHeader = "GIF87a" Then
GifHeader = GIF87A
ElseIf strGifHeader = "GIF89a" Then
GifHeader = GIF89A
End If
'Test if the Gif is animated or not
FirstFrame = InStr(13, FileBuffer, Chr(33) & Chr(249))
ActualFrame = FirstFrame
'if the image isn't animated, then just draw it;)
If InStr(FirstFrame + 2, FileBuffer, Chr(33) & Chr(249)) = 0 Then
aimg(0).Picture = LoadPicture(strFileName)
aimg(0).Tag = 0
Exit Function
End If
'Logical Screen Description
strLogicalScreenDescription = Mid$(FileBuffer, 7, 7)
LSDLogicalScreenDescription.GifWidth = Asc(Mid(strLogicalScreenDescription, 1, 1)) + Asc(Mid(strLogicalScreenDescription, 2, 1)) * 256
LSDLogicalScreenDescription.GifHeight = Asc(Mid(strLogicalScreenDescription, 3, 1)) + Asc(Mid(strLogicalScreenDescription, 4, 1)) * 256
PackedField = Asc(Mid$(strLogicalScreenDescription, 5, 1))
LSDLogicalScreenDescription.GlobalColorFlag = (PackedField And 128) / 2 ^ 7
LSDLogicalScreenDescription.ColorResolution = (PackedField And 112) / 2 ^ 4
LSDLogicalScreenDescription.SortFlag = (PackedField And 8) / 2 ^ 3
' NOTE - This value is meanless if GlobalColorFlag is 0
LSDLogicalScreenDescription.GlobalColorSize = PackedField And 7
LSDLogicalScreenDescription.GlobalColorSize = 3 * (2 ^ (LSDLogicalScreenDescription.GlobalColorSize + 1))
LSDLogicalScreenDescription.BackgroundColor = Asc(Mid$(strLogicalScreenDescription, 6, 1))
LSDLogicalScreenDescription.PixelRadio = Asc(Mid$(strLogicalScreenDescription, 7, 1))
'image count
i = 0
ReDim Preserve fraFrame(i)
Do
'get frame string
If InStr(ActualFrame + 2, FileBuffer, Chr(33) & Chr(249)) <> 0 Then
FrameEnds = InStr(ActualFrame + 2, FileBuffer, Chr(33) & Chr(249)) - 2
Else
FrameEnds = InStr(ActualFrame + 2, FileBuffer, Chr(59)) - 1
End If
strFrame = Mid$(FileBuffer, ActualFrame, Len(FileBuffer) - FirstFrame)
'Get Grafic Control
PackedField = Asc(Mid$(strFrame, 4, 1))
fraFrame(i).GCGraphicControl.Disposal = (PackedField And 12) / 2 ^ 2
' ADDED BY JMS
fraFrame(i).GCGraphicControl.UserInput = (PackedField And 2) / 2 ^ 1
' ADDED BY JMS
fraFrame(i).GCGraphicControl.TransparentFlag = (PackedField And 1)
fraFrame(i).GCGraphicControl.Delay = (Asc(Mid(strFrame, 5, 1)) + Asc(Mid(strFrame, 6, 1)) * 256) * 10
fraFrame(i).GCGraphicControl.TransparentColorIndex = Asc(Mid$(strFrame, 7, 1))
'Get Image Description
fraFrame(i).IDImageDescription.FrameLeft = Asc(Mid(strFrame, 10, 1)) + Asc(Mid(strFrame, 11, 1)) * 256
fraFrame(i).IDImageDescription.FrameTop = Asc(Mid(strFrame, 12, 1)) + Asc(Mid(strFrame, 13, 1)) * 256
fraFrame(i).IDImageDescription.FrameWidth = Asc(Mid(strFrame, 14, 1)) + Asc(Mid(strFrame, 15, 1)) * 256
fraFrame(i).IDImageDescription.FrameHeight = Asc(Mid(strFrame, 16, 1)) + Asc(Mid(strFrame, 17, 1)) * 256
'If the image array don't exist then create\load it
If i > 0 Then
Load aimg(i)
End If
'create the image temp
fNum = FreeFile
Open "temp.gif" For Binary As fNum
PictureBuffer = Mid$(FileBuffer, 1, FirstFrame - 1) & Mid$(FileBuffer, ActualFrame, FrameEnds) & Chr(59) '3B
Put #fNum, 1, PictureBuffer
Close fNum
'Now change the backcolor
aimg(i).BackColor = fraFrame(i).GCGraphicControl.TransparentColorIndex
'now load the image
aimg(i).Picture = LoadPicture("temp.gif")
'change the properties
aimg(i).Tag = fraFrame(i).GCGraphicControl.Delay
'test if theres another image
If InStr(ActualFrame + 2, FileBuffer, Chr(33) & Chr(249) & chr(4)) = 0 Then
Exit Do
Else
ActualFrame = InStr(ActualFrame + 2, FileBuffer, Chr(33) & Chr(249))
i = i + 1
If i > 0 Then ReDim Preserve fraFrame(i)
End If
Loop
'now we can delete the temp file
Kill "temp.gif"
LoadGifFile = i + 1
'Control the Disposal codes
If aimg.Count > 1 Then
Load aimg(aimg.Count)
For i = 0 To aimg.Count - 2
Select Case fraFrame(i).GCGraphicControl.Disposal
Case 0, 1 ' Leave
If i = 0 Then i = 1
BitBlt aimg(aimg.Count - 1).hdc, 0, 0, aimg(i - 1).ScaleWidth, aimg(i - 1).ScaleHeight, aimg(i - 1).hdc, 0, 0, vbSrcCopy
If fraFrame(i).GCGraphicControl.TransparentFlag <> 0 Then
TransparentBlt aimg(aimg.Count - 1).hdc, _
fraFrame(i).IDImageDescription.FrameLeft, fraFrame(i).IDImageDescription.FrameTop, _
aimg(i).ScaleWidth, aimg(i).ScaleHeight, aimg(i).hdc, 0, 0, aimg(i).ScaleWidth, _
aimg(i).ScaleHeight, fraFrame(i).GCGraphicControl.TransparentColorIndex
Else
BitBlt aimg(aimg.Count - 1).hdc, fraFrame(i).IDImageDescription.FrameLeft, fraFrame(i).IDImageDescription.FrameTop, aimg(i).ScaleWidth, aimg(i).ScaleHeight, aimg(i).hdc, 0, 0, vbSrcCopy
End If
aimg(i).Picture = aimg(aimg.Count - 1).Image
aimg(aimg.Count - 1).Cls
Case 3
BitBlt aimg(aimg.Count - 1).hdc, 0, 0, aimg(i).ScaleWidth, aimg(i).ScaleHeight, aimg(i).hdc, 0, 0, vbSrcCopy
aimg(i).Cls
If fraFrame(i).GCGraphicControl.TransparentFlag <> 0 Then
TransparentBlt aimg(aimg.Count - 1).hdc, _
fraFrame(i).IDImageDescription.FrameLeft, fraFrame(i).IDImageDescription.FrameTop, _
aimg(i).ScaleWidth, aimg(i).ScaleHeight, aimg(i).hdc, 0, 0, aimg(i).ScaleWidth, _
aimg(i).ScaleHeight, GetPixel(aimg(i).hdc, 0, 0)
Else
TransparentBlt aimg(aimg.Count - 1).hdc, _
fraFrame(i).IDImageDescription.FrameLeft, fraFrame(i).IDImageDescription.FrameTop, _
aimg(i).ScaleWidth, aimg(i).ScaleHeight, aimg(i).hdc, 0, 0, aimg(i).ScaleWidth, _
aimg(i).ScaleHeight, LSDLogicalScreenDescription.BackgroundColor
End If
aimg(i).Picture = aimg(aimg.Count - 1).Image
aimg(aimg.Count - 1).Cls
End Select
Debug.Print fraFrame(i).GCGraphicControl.Disposal
Next i
Unload aimg(aimg.Count - 1)
End If
End Function
test these function
Reply With Quote
Originally Posted by jmsrickland
