|
-
Nov 9th, 2008, 02:07 PM
#1
Thread Starter
PowerPoster
animated gif files problem
i'm using VB6 in UC section.
my animated gif code isn't good, is why i'm update it:
Code:
Option Explicit
Private MyPath As String
Public TotalFrames As Long
Public LogicalWidth As Long, LogicalHeight As Long
Public myBackColor As Long
Public sGifMagic As String, Trailer As String
Public TimeSpeed As Long 'used in UC
Private Type BITMAPFILEHEADER '14 bytes
bfType As Integer
bfSize(3) As Byte 'Long
'bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
'bfOffBits As Long
bfOffBits(3) As Byte
End Type
Private Declare Function GetTempFileName _
Lib "KERNEL32" Alias "GetTempFileNameA" _
(ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long
Private Function GetUniqueFilename(Optional Path As String = "", _
Optional Prefix As String = "", _
Optional UseExtension As String = "") _
As String
' Input strings must be NULL terminated.
Dim wUnique As Long
Dim lpTempFileName As String
Dim lngRet As Long
Dim FileHeader As BITMAPFILEHEADER
wUnique = 0
If Path = "" Then Path = CurDir
lpTempFileName = Space(255)
lngRet = GetTempFileName(Path, Prefix, _
wUnique, lpTempFileName)
lpTempFileName = Left(lpTempFileName, _
InStr(lpTempFileName, Chr(0)) - 1)
Call Kill(lpTempFileName)
If Len(UseExtension) > 0 Then
lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
End If
GetUniqueFilename = lpTempFileName
End Function
Private Sub AddDirSep(strPathName As String)
If Right$(RTrim$(strPathName), 1) <> "\" Then
strPathName = RTrim$(strPathName) & "\"
End If
End Sub
Public Function LoadGif(sFile As String, aImg As Variant) As Boolean
On Error Resume Next
Dim i As Long
Dim lngFind As Long, lngPreviousFind As Long, strTempFile As String
Dim hFile As Long
Dim sFileHeader As String, strTemp As String
Dim sBuff As String
Dim sPicsBuff As String
Dim TimeWait As Long
Dim bolDoLastImage As Boolean
TotalFrames = 0
If Dir$(sFile) = "" Or sFile = "" Then
Exit Function
End If
MyPath = App.Path
AddDirSep MyPath
If aImg.Count > 1 Then
For i = 1 To aImg.Count - 1
Unload aImg(i)
Next i
End If
'load the gif into a string buffer
hFile = FreeFile
Open sFile For Binary Access Read As hFile
sBuff = String(LOF(hFile), Chr(0))
Get #hFile, , sBuff
Close #hFile
'find size of color table
If Asc(Mid(sBuff, 11, 1)) And 128 Then
lngFind = Asc(Mid(sBuff, 11, 1)) And 7
lngFind = 3 * (2 ^ (lngFind + 1))
End If
lngFind = lngFind + 13
sFileHeader = Left(sBuff, lngFind)
'GIF?
If Left$(sFileHeader, 3) <> "GIF" Then Exit Function
'logical dimensions
LogicalWidth = Asc(Mid(sBuff, 7, 1)) + Asc(Mid(sBuff, 8, 1)) * 256&
LogicalHeight = Asc(Mid(sBuff, 9, 1)) + Asc(Mid(sBuff, 10, 1)) * 256&
'temporary file
hFile = FreeFile
strTempFile = GetUniqueFilename(MyPath, "p" & Chr(0), "GIF")
Open strTempFile For Binary As hFile
'locate start of a frame
lngFind = InStr(Len(sFileHeader) + 1, sBuff, sGifMagic) + 1
'first image
If lngFind > 1 Then
sPicsBuff = sFileHeader & Mid(sBuff, Len(sFileHeader) + 1, lngFind - (Len(sFileHeader) + 1)) & Trailer
Put #hFile, 1, sPicsBuff
Load aImg(1)
aImg(1).Visible = True
aImg(1).Tag = "10"
aImg(1).Picture = LoadPicture(strTempFile)
If aImg(1).Picture.handle <> 0 Then
TotalFrames = 1
Else
Unload aImg(1)
End If
lngPreviousFind = lngFind
lngFind = InStr(lngPreviousFind + 1, sBuff, sGifMagic) + 1
Else
'only one image
lngPreviousFind = Len(sFileHeader) + 1
lngFind = Len(sBuff)
bolDoLastImage = True
End If
'search next image
Do While lngFind > 1
TotalFrames = TotalFrames + 1
Load aImg(TotalFrames)
aImg(TotalFrames).Visible = True
strTemp = Mid(sBuff, lngPreviousFind, lngFind - lngPreviousFind)
sPicsBuff = sFileHeader & strTemp & Trailer
Put #hFile, 1, sPicsBuff
'redraw?
aImg(TotalFrames).DrawStyle = (Asc(Mid(strTemp, 4, 1)) And 28) / 4
'load picture
aImg(TotalFrames).Picture = LoadPicture(strTempFile)
If bolDoLastImage Then
If aImg(TotalFrames).Picture.handle = 0 Then
Unload aImg(TotalFrames)
TotalFrames = TotalFrames - 1
Exit Do
End If
End If
'frame delay
TimeWait = ((Asc(Mid(strTemp, 5, 1))) + (Asc(Mid(strTemp, 6, 1)) * 256&)) * 10&
If TimeWait = 0 Then TimeWait = 1
If TimeWait > 65535 Then TimeWait = 65535
TimeSpeed = CStr(TimeWait)
'position
If TotalFrames > 1 Then
aImg(TotalFrames).Left = aImg(1).Left + Asc(Mid(strTemp, 10, 1)) + (Asc(Mid(strTemp, 11, 1)) * 256&)
aImg(TotalFrames).Top = aImg(1).Top + Asc(Mid(strTemp, 12, 1)) + (Asc(Mid(strTemp, 13, 1)) * 256&)
End If
lngPreviousFind = lngFind
lngFind = InStr(lngPreviousFind + 1, sBuff, sGifMagic) + 1
'last image
If lngFind <= 1 Then
If Not bolDoLastImage Then
lngFind = Len(sBuff)
bolDoLastImage = True
End If
End If
Loop
If TotalFrames > 1 Then
LoadGif = True
Else
LoadGif = False
End If
Close #hFile
Kill strTempFile
On Error GoTo 0
End Function
and heres how i use it(here is ok, before update animated gif code):
Code:
Public Property Let FileName(New_FileName As String)
If blnDestroyed = True Then Exit Property
Dim i As Integer
strFileName = New_FileName
tmrAnimation.Enabled = False
On Error Resume Next
If (Dir(strFileName) = "" Or ValidFile(UCase(strFileName)) = False) Then
UserControl.Picture = Nothing
UserControl.MaskPicture = Nothing
UserControl.MaskColor = Null
UserControl.Cls
Strip.Activate = False
StripsActivate = Strip.Activate
lngActualSubImage = 0
lngTotalSubImages = 0
aniAnimation = AnimationStopped
Exit Property
End If
If PicAnimation.Count > 1 Then
For i = 1 To PicAnimation.Count - 1
Unload PicAnimation(i)
If shpSubImage.Count > 1 Then
Unload shpSubImage(i)
End If
Next i
End If
If (UCase(strFileName) Like "*.GIF") Then
If LoadGif(strFileName, PicAnimation) = True Then
If PicAnimation.Count = 1 Then
PicAnimation(0).Picture = LoadPicture(strFileName)
Else
lngChangeImageTime = TimeSpeed
tmrAnimation.Interval = lngChangeImageTime
End If
End If
UserControl.Width = PicAnimation(0).ScaleWidth * Screen.TwipsPerPixelX
UserControl.Height = PicAnimation(0).ScaleHeight * Screen.TwipsPerPixelY
ElseIf (UCase(strFileName) Like "*.ANI") Or (UCase(strFileName) Like "*.CUR") Then
If AnimatedCursor(strFileName, PicAnimation) Then
If PicAnimation.Count > 1 Then tmrAnimation.Interval = lngChangeImageTime
UserControl.Width = PicAnimation(0).ScaleWidth * Screen.TwipsPerPixelX
UserControl.Height = PicAnimation(0).ScaleHeight * Screen.TwipsPerPixelY
End If
Else
tmrAnimation.Enabled = False
PicAnimation(0).Picture = LoadPicture(strFileName)
End If
lngActualSubImage = 0
lngTotalSubImages = IFF(Strip.Activate = True, PicAnimation.Count - 1, PicAnimation.Count)
If Strip.Activate = True Then
UserControl.Width = PicAnimation(1).ScaleWidth * Screen.TwipsPerPixelX
UserControl.Height = PicAnimation(1).ScaleHeight * Screen.TwipsPerPixelY
Else
UserControl.Width = PicAnimation(0).ScaleWidth * Screen.TwipsPerPixelX
UserControl.Height = PicAnimation(0).ScaleHeight * Screen.TwipsPerPixelY
End If
If lngTotalSubImages = 1 Then
If Strip.Activate = True Then
UserControl.Picture = PicAnimation(1).Image
UserControl.BackColor = PicAnimation(1).BackColor
Else
UserControl.Picture = PicAnimation(0).Image
UserControl.BackColor = PicAnimation(0).BackColor
End If
Else
If Strip.Activate = True Then
UserControl.Picture = PicAnimation(1).Image
UserControl.BackColor = PicAnimation(1).BackColor
Else
UserControl.Picture = PicAnimation(0).Image
UserControl.BackColor = PicAnimation(0).BackColor
End If
aniAnimation = AnimationPlay
tmrAnimation.Enabled = Ambient.UserMode
End If
Col.Height = Extender.Height
Col.Left = Extender.Left
Col.Top = Extender.Top
Col.Width = Extender.Width
StripsActivate = Strip.Activate
Call ShowImage
PropertyChanged "FileName"
End Property
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|