Code:
'Method Values :
'0 - No disposal specified. The decoder is _
not required to take any action.
'1 - Do not dispose. The graphic is to be left _
in place.
'2 - Restore to background color. The area used by the _
graphic must be restored to the background color.
'3 - Restore to previous. The decoder is required to _
restore the area overwritten by the graphic with _
what was there prior to rendering the graphic.
'4-7 - To be defined.
Option Explicit
Private Type DisposedValues
Disposed As Integer
FrameXPos As Long
FrameYPos As Long
End Type
Public Enum GifType
GIF87A = 0
GIF89A = 1
End Enum
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 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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public RepeatTimes As Long 'This one calculates,
' but don't use in this sample. If You need, You
' can add simple checking at Timer1_Timer Procedure
Public TotalFrames As Long
Public GifTypeFile As GifType
Public Dispose() As DisposedValues
Public Function LoadGif(sFile As String, aImg As Variant) As Boolean
If Dir$(sFile) = "" Or sFile = "" Then
MsgBox "File " & sFile & " not found", vbCritical
Exit Function
End If
If Mid$(UCase(sFile), Len(sFile) - 2, 3) <> "GIF" Then Exit Function
'On Error GoTo ErrHandler
'On Error Resume Next
Dim fNum As Integer
Dim imgHeader As String, fileHeader As String
Dim buf$, picbuf$
Dim imgCount As Integer
Dim i&, j&, FrameX&, FrameY&, TimeWait&
Dim GifEnd As String
Dim intDisposed() As Integer
Dim intHeight As Integer
Dim intWidth As Integer
GifEnd = Chr(0) & Chr(33) & Chr(249) '<---only for animated GIF's
'unload all pictureboxes\images
For i = 1 To aImg.Count - 1
Unload aImg(i)
Next i
'Get GIF File into buffer
fNum = FreeFile
Open sFile For Binary Access Read As fNum
buf = String(LOF(fNum), Chr(0))
Get #fNum, , buf
Close fNum
i = 1
imgCount = 0
j = InStr(1, buf, GifEnd) + 1 '<--- j = 1 or 0 if not a animated gif ---- j > 1 if it is an animated gif
'if the Gif isn't animated
'then just show the image
If j < 2 Then
aImg(0).Picture = LoadPicture(sFile)
TotalFrames = aImg.Count - 1
aImg(0).Tag = 0
LoadGif = True
Exit Function
End If
fileHeader = Left(buf, j)
'if the file is gif structure
If Left$(fileHeader, 1) <> "G" Then
MsgBox "This file is not a *.gif file", vbCritical
Exit Function
End If
LoadGif = True
'Get gif type
'intWidth = Asc(Mid$(fileHeader, 7, 4))
'intHeight = Asc(Mid$(fileHeader, 9, 4))
'BackColor = Asc(Mid$(fileHeader, 11, 1))
'Gif Type
If Left$(fileHeader, 6) = "GIF89a" Then
GifTypeFile = GIF89A
Else
GifTypeFile = GIF87A
End If
i = j + 2
'how many times the animation is repeated
If Len(fileHeader) >= 127 Then
RepeatTimes& = Asc(Mid(fileHeader, 126, 1)) + (Asc(Mid(fileHeader, 127, 1)) * 256&)
Else
RepeatTimes = 0
End If
Do
' Split GIF Files at separate pictures
' and load them into Image Array
imgCount = imgCount + 1
j = InStr(i, buf, GifEnd) + 3
If j > Len(GifEnd) Then
fNum = FreeFile
Open "temp.gif" For Binary As fNum
picbuf = String(Len(fileHeader) + j - i, Chr(0))
picbuf = fileHeader & Mid(buf, i - 1, j - i)
Put #fNum, 1, picbuf
imgHeader = Left(Mid(buf, i - 1, j - i), 16)
Close fNum
'frame delay time
TimeWait = ((Asc(Mid(imgHeader, 4, 1))) + (Asc(Mid(imgHeader, 5, 1)) * 256&)) * 10&
If imgCount > 1 Then
'Get frame position
FrameX = Asc(Mid(imgHeader, 9, 1)) + (Asc(Mid(imgHeader, 10, 1)) * 256&)
FrameY = Asc(Mid(imgHeader, 11, 1)) + (Asc(Mid(imgHeader, 12, 1)) * 256&)
'load control for show the image
Load aImg(imgCount - 1)
'change the control position
'for show the image in right position
aImg(imgCount - 1).Left = FrameX * Screen.TwipsPerPixelX
aImg(imgCount - 1).Top = FrameY * Screen.TwipsPerPixelY
End If
' Use .Tag Property to save TimeWait interval for separate Image
aImg(imgCount - 1).Tag = TimeWait
aImg(imgCount - 1).Picture = LoadPicture("temp.gif")
'Get the disposal values and positions from frames
ReDim Preserve Dispose(aImg.Count - 1)
Dispose(aImg.Count - 1).Disposed = Asc(Mid(imgHeader, 3, 1)) / 4 And 3
Dispose(aImg.Count - 1).FrameXPos = FrameX
Dispose(aImg.Count - 1).FrameYPos = FrameY
'kill temp file
Kill ("temp.gif")
i = j
End If
'DoEvents
Loop Until j = 3
' If there are one more Image - Load it
If i < Len(buf) Then
fNum = FreeFile
Open "temp.gif" For Binary As fNum
picbuf = String(Len(fileHeader) + Len(buf) - i, Chr(0))
picbuf = fileHeader & Mid(buf, i - 1, Len(buf) - i)
Put #fNum, 1, picbuf
imgHeader = Left(Mid(buf, i - 1, Len(buf) - i), 16)
Close fNum
TimeWait = ((Asc(Mid(imgHeader, 4, 1))) + (Asc(Mid(imgHeader, 5, 1)) * 256)) * 10
If imgCount > 1 Then
FrameX = Asc(Mid(imgHeader, 9, 1)) + (Asc(Mid(imgHeader, 10, 1)) * 256)
FrameY = Asc(Mid(imgHeader, 11, 1)) + (Asc(Mid(imgHeader, 12, 1)) * 256)
Load aImg(imgCount - 1)
aImg(imgCount - 1).Left = FrameX * Screen.TwipsPerPixelX
aImg(imgCount - 1).Top = FrameY * Screen.TwipsPerPixelY
End If
aImg(imgCount - 1).Tag = TimeWait
aImg(imgCount - 1).Picture = LoadPicture("temp.gif")
ReDim Preserve Dispose(aImg.Count - 1)
Dispose(aImg.Count - 1).Disposed = Asc(Mid(imgHeader, 3, 1)) / 4 And 3
Dispose(aImg.Count - 1).FrameXPos = FrameX
Dispose(aImg.Count - 1).FrameYPos = FrameY
Kill ("temp.gif")
End If
TotalFrames = aImg.Count - 1
LoadGif = True
If aImg.Count >= 2 Then
Load aImg(aImg.Count)
aImg(aImg.Count - 1).Width = aImg(0).Width
aImg(aImg.Count - 1).Height = aImg(0).Height
For i = 1 To aImg.Count - 2
If Dispose(i).Disposed = 0 Then
'nothing
ElseIf Dispose(i).Disposed = 1 Then
'previous frame + actual frame(transparent) = result frame
aImg(aImg.Count - 1).Picture = aImg(i - 1).Image
Debug.Print TransparentBlt(aImg(aImg.Count - 1).hdc, Dispose(i).FrameXPos, Dispose(i).FrameYPos, aImg(i).ScaleWidth, aImg(i).ScaleHeight, aImg(i).hdc, 0, 0, aImg(i).ScaleWidth, aImg(i).ScaleHeight, GetPixel(aImg(i).hdc, 0, 0))
aImg(i).Picture = aImg(aImg.Count - 1).Image
aImg(i).Left = FrameX * Screen.TwipsPerPixelX
aImg(i).Top = FrameY * Screen.TwipsPerPixelY
aImg(aImg.Count - 1).Cls
End If
Next i
Unload aImg(aImg.Count - 1)
End If
LoadGif = True
Exit Function
ErrHandler:
MsgBox "Error No. " & Err.Number & " when reading file", vbCritical
LoadGif = False
On Error GoTo 0
End Function
the frame 0 position isn't correct. how can i get it?
Reply With Quote