Option Explicit
Dim NumberOfTimesToRepeatSequence As Long
Dim RepeatedCount As Long
Dim MaxCnt As Integer
Dim ImgCnt As Integer
Private Sub Form_Load()
On Error GoTo Form_LoadError
Image1(0).Left = 0
Image1(0).Top = 0
'lugar de la ruta de acceso al GIF que desea animar aquí
Call DecodeGif("C:\FicheroGifAnimado.gif")
'PONER AQUI EL FICHERO GIF
Exit Sub
Form_LoadError:
MsgBox Err.Description
End Sub
Public Sub DecodeGif(PathToGifFile As String)
' si hay errores saltamos a la etiqueta DecodeGifError
On Error GoTo DecodeGifError
'Declaramos las variables
Dim FNumb As Integer
Dim GifBuffer As String
Dim GifHeader As String
Dim SectionStart As Long
Dim SectionEnd As Long
Dim SectionMarker As String
Dim ImageCount As Integer
Dim i As Integer
Dim NewPicBuff As String
Dim ImageHeader As String
Dim DisplayTime As Long
Dim LftOffSet As Long
Dim TopOffSet As Long
' comprobamos básicamente si existe el fichero contenido en la variable PathToGifFile
If Dir(PathToGifFile) = vbNullString Then
MsgBox "Dónde está el GIF!?"
' si no lo encuentra salimos
Exit Sub
End If
'detenemos el timer y cualquier animación que pueda estar en marcha
Timer1.Enabled = False
' eliminamos las imágenes existentes por si ya hemos mostrado antes otra animación
For i = 1 To Image1.Count - 1
Unload Image1(i)
Next i
' solo dejamos la imagen (0) como base para crear mas
' nos aseguramos de que el control image no va a cambiar de tamaño para adaptarse al tamaño de la imagen
Image1(0).Stretch = False
'set value(s)
'valor de referencia (s)
SectionMarker = Chr(0) & "!ù"
' Esto imagino que es algo técnico sobre el formato de un fichero gif.
' Posiblemente son caracteres que encontraremos precediendo a cada imagen o algo así.
' Puntero que iremos usando para guardar la posicion de comienzo de cada seccion con la que trabajemos
SectionStart = 1
' el sistema nos dá un numero de fichero que no se está usando en otro open en este momento
FNumb = FreeFile ' <--- Esto es mejor que esto ---> FNumb = 1
'abrimos el fichero gif
Open PathToGifFile For Binary As #FNumb
' leemos todo el fichero y lo cargamos en un string llamado GifBuffer
GifBuffer = Input(FileLen(PathToGifFile), #FNumb)
' y lo cerramos.
Close #FNumb
' Buscamos el final del encabezado del fichero gif usando los caracteres de sectionmarker
SectionEnd = InStr(SectionStart, GifBuffer, SectionMarker) + Len(SectionMarker) - 2
'guardamos esa parte del comienzo del gif (encabezado-header) que contendrá datos sobre el gif...
GifHeader = Left(GifBuffer, SectionEnd)
' guardamos la posición de inicio de la primera imagen
SectionStart = SectionEnd + 2
'según la longitud del encabezado calculamos si el gif es continuo o se repite un numero limitado de veces
If Len(GifHeader) > 127 Then
' si es mayor que 127 extraemos la cantidad de ciclos que se va a repetir con la formula:
' ((Numero ascii del caracter 127) * 256) + Numero ascii del caracter 126
NumberOfTimesToRepeatSequence = Asc(Mid(GifHeader, 127, 1))
NumberOfTimesToRepeatSequence = NumberOfTimesToRepeatSequence * 256
NumberOfTimesToRepeatSequence = NumberOfTimesToRepeatSequence + Asc(Mid(GifHeader, 126, 1))
Else
' si el encabezado no es mayor de 127 es que el gif se repite continuamente
NumberOfTimesToRepeatSequence = 0 'bucle infinito
End If
' aqui extraemos las imagenes
' esto no se como funciona exactamente pero hace un bucle mientras queden imagenes que extraer
Do While SectionEnd <> Len(SectionMarker)
'llevamos un contador de imagenes extraidas para crear los controles image
ImageCount = ImageCount + 1
'para saber dónde termina la sección
SectionEnd = InStr(SectionStart, GifBuffer, SectionMarker) + Len(SectionMarker)
'Nos aseguramos de que hay alguna imagen en el gif
If SectionEnd > Len(SectionMarker) Then
'capturamos el trozo marcado y lo precedemos con el encabezado del fichero Gif (imagino que para que mantenga el formato al guardarlo como imagen individual)
NewPicBuff = GifHeader & Mid(GifBuffer, SectionStart - 1, SectionEnd - SectionStart)
'Ahora se escribe la imagen a un archivo para poder cargarla como nosotros queremos hacerlo
FNumb = FreeFile
Open App.Path & "\temp.gif" For Binary As #FNumb
Put #FNumb, 1, NewPicBuff
Close #FNumb
'ahora guardamos los 16 primeros caracteres de cada imagen que nos dirán su duración, etc
ImageHeader = Left(Mid(GifBuffer, SectionStart - 1, SectionEnd - SectionStart), 16)
'Ahora calculamos la duración de la imagen actual con una formula que usa el cuarto y el quinto de esos 16 caracteres guardados
DisplayTime = Asc(Mid(ImageHeader, 5, 1))
DisplayTime = DisplayTime * 256
DisplayTime = DisplayTime + Asc(Mid(ImageHeader, 4, 1))
DisplayTime = DisplayTime * 10
' si no es la primera imagen que guardamos...
If ImageCount > 1 Then
' calculamos la posición de la nueva imagen dentro del formulario usando para ello los caracteres 9,10,11 y 12 de los 16 de la cabecera de la imagen.
LftOffSet = Asc(Mid(ImageHeader, 10, 1))
LftOffSet = LftOffSet * 256
LftOffSet = LftOffSet + Asc(Mid(ImageHeader, 9, 1))
TopOffSet = Asc(Mid(ImageHeader, 12, 1))
TopOffSet = TopOffSet * 256
TopOffSet = TopOffSet + Asc(Mid(ImageHeader, 11, 1))
'carga un nuevo control image y establece sus propiedades
Load Image1(ImageCount - 1)
Image1(ImageCount - 1).ZOrder 0 ' zorder nunca he entendido como funciona (ni usado)
Image1(ImageCount - 1).Left = Image1(0).Left + (LftOffSet * 15)
Image1(ImageCount - 1).Top = Image1(0).Top + (TopOffSet * 15)
End If
' Añado esto para evitar que se cuele un valor de interval no válido.
If DisplayTime < 0 Then DisplayTime = 0
If DisplayTime > 65535 Then DisplayTime = 65535
' creo que ya no es necesario pero al principio me pasaba y por seguridad lo dejo.
'guardamos en la propiedad Tag el tiempo que debe mostrarse la imagen
Image1(ImageCount - 1).Tag = DisplayTime
' cargamos la imagen que habíamos guardado en un fichero
Image1(ImageCount - 1).Picture = LoadPicture(App.Path & "\temp.gif")
'la imagen ya no hace falta y se elimina
Kill App.Path & "\temp.gif"
' nos colocamos en posicion para comenzar con la siguiente imagen a cargar
SectionStart = SectionEnd
End If
' y asi tantas veces como imagenes haya
Loop
' si aun quedan datos en el fichero creamos una última imagen con eso
If SectionStart < Len(GifBuffer) Then
NewPicBuff = GifHeader & Mid(GifBuffer, SectionStart - 1, Len(GifBuffer) - SectionStart)
' el proceso es igual que antes asi que quito comentarios.
FNumb = FreeFile
Open App.Path & "\temp.gif" For Binary As #FNumb
Put #FNumb, 1, NewPicBuff
Close #FNumb
ImageHeader = Left(Mid(GifBuffer, SectionStart - 1, Len(GifBuffer) - SectionStart), 16)
DisplayTime = Asc(Mid(ImageHeader, 5, 1))
DisplayTime = DisplayTime * 256
DisplayTime = DisplayTime + Asc(Mid(ImageHeader, 4, 1))
DisplayTime = DisplayTime * 10
If ImageCount > 1 Then
LftOffSet = Asc(Mid(ImageHeader, 10, 1))
LftOffSet = LftOffSet * 256
LftOffSet = LftOffSet + Asc(Mid(ImageHeader, 9, 1))
TopOffSet = Asc(Mid(ImageHeader, 12, 1))
TopOffSet = TopOffSet * 256
TopOffSet = TopOffSet + Asc(Mid(ImageHeader, 11, 1))
Load Image1(ImageCount - 1)
Image1(ImageCount - 1).ZOrder 0
Image1(ImageCount - 1).Left = Image1(0).Left + (LftOffSet * 15)
Image1(ImageCount - 1).Top = Image1(0).Top + (TopOffSet * 15)
End If
If DisplayTime < 0 Then DisplayTime = 0
If DisplayTime > 65535 Then DisplayTime = 65535
Image1(ImageCount - 1).Tag = DisplayTime
Image1(ImageCount - 1).Picture = LoadPicture(App.Path & "\temp.gif")
Kill App.Path & "\temp.gif"
End If
' reiniciamos el contador de imagenes mostradas en el timer
ImgCnt = -1
' y guardamos el numero de imagenes totales
MaxCnt = Image1.Count - 1
' muestro ya la primera imagen
Image1(0).Visible = True
' esto creo que tambien sobra.
' lo puse para que no se saltase la primera imagen pero creo que se arregló al poner ImgCnt = - 1
'configurar el timer con la duración de la primera imagen
Timer1.Interval = CInt(Image1(0).Tag)
'y para finalizar activamos el timer para comenzar la animacion
Timer1.Enabled = True
Exit Sub
DecodeGifError:
' esto lo añadi para saltarme un error
If Image1.Count > 0 And Err.Number = 50003 Then
Unload Image1(Image1.Count - 1)
ImageCount = ImageCount - 1
Else
MsgBox Err.Number & " - " & Err.Description
End If
Err.Clear
' Añado esto para extraer todos los
' fotogramas que pueda aun con un error
Resume Next
End Sub