9
« en: Febrero 01, 2017, 03:28:25 pm »
hola a todos tengo la siguiente clase que me devuelve todas las imagenes y tiempos de un archivo gif.
Option Explicit
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function RedrawWindow Lib "user32.dll" (ByVal hwnd As Long, ByRef lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
'Private Declare Function DrawIconEx Lib "user32.dll" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
'Private Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, riid As Any, ByVal fOwn As Long, ipic As IPicture) As Long
Private Type PICTDESC
cbSize As Long
pictType As Long
hIcon As Long
hPal As Long
End Type
' custom UDT - animated gif frame properties
Private Type AniGifProps
aPic As StdPicture ' the image itself
aInterval As Integer ' the gif-coded frame interval
aTop As Long ' the gif-coded top offset
aLeft As Long ' the gif-coded left offset
aMisc As Long ' could be remarks or other needed information
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private updateRect As RECT
' collection of gif frames
Private aniFrames() As AniGifProps
' used to help prevent flicker during animation
Public picBkBuff As StdPicture
Private m_contador As Integer
Public ruta As String
Public Function LoadGif(aniPath As String) As Boolean
On Error GoTo ErrHandler
Dim fNum As Integer
Dim MaxX As Long, MaxY As Long
Dim MaxOffsetX As Long, MaxOffsetY As Long
Dim imgSize As Long
Dim imgHeader As String, fileHeader As String
Dim buf$, picbuf$
Dim imgCount As Integer
Dim I&, J&, xOff&, yOff&, TimeWait&
Dim GifEnd As String
GifEnd = Chr(0) & Chr(33) & Chr(249) ' flag indicating end of file
fNum = FreeFile
Open aniPath For Binary Access Read As fNum
buf = String(LOF(fNum), Chr(0))
Get #fNum, , buf 'Get GIF File into buffer
Close fNum
I = 1
J = InStr(1, buf, GifEnd) + 1
fileHeader = Left(buf, J)
If Left$(fileHeader, 3) <> "GIF" Then
MsgBox "This file is not an animated GIF file", vbInformation + vbOKOnly
Exit Function
End If
cleargif
ruta = aniPath
I = J + 2
Do
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
ReDim Preserve aniFrames(0 To imgCount)
With aniFrames(imgCount)
.aInterval = ((Asc(Mid(imgHeader, 4, 1))) + (Asc(Mid(imgHeader, 5, 1)) * 256)) * 10
Set .aPic = LoadPicture("temp.gif")
.aLeft = Val(Asc(Mid(imgHeader, 9, 1)) + (Asc(Mid(imgHeader, 10, 1)) * 256&))
.aTop = Val(Asc(Mid(imgHeader, 9, 1)) + (Asc(Mid(imgHeader, 10, 1)) * 256&))
End With
imgCount = imgCount + 1
I = J
Kill "temp.gif"
End If
Loop Until J = 3
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
ReDim Preserve aniFrames(0 To imgCount)
With aniFrames(imgCount)
.aInterval = ((Asc(Mid(imgHeader, 4, 1))) + (Asc(Mid(imgHeader, 5, 1)) * 256)) * 10
Set .aPic = LoadPicture("temp.gif")
.aLeft = Val(Asc(Mid(imgHeader, 9, 1)) + (Asc(Mid(imgHeader, 10, 1)) * 256&))
.aTop = Val(Asc(Mid(imgHeader, 9, 1)) + (Asc(Mid(imgHeader, 10, 1)) * 256&))
End With
Kill "temp.gif"
End If
For imgCount = 0 To UBound(aniFrames)
With aniFrames(imgCount)
If .aInterval > 60000 Then ' no interval > 60000
.aInterval = 60000
ElseIf .aInterval = 0 Then ' no zero intervals (use 100 as default)
.aInterval = 100
End If
imgSize = ConvertHimetrix2Pixels(.aPic.Width, True) + Abs(.aLeft)
If imgSize > MaxX Then MaxX = imgSize
imgSize = ConvertHimetrix2Pixels(.aPic.Height, False) + Abs(.aTop)
If imgSize > MaxY Then MaxY = imgSize
If .aLeft < 0 Then
If Abs(.aLeft) > MaxOffsetX Then MaxOffsetX = Abs(.aLeft)
End If
If .aTop < 0 Then
If Abs(.aTop) > MaxOffsetY Then MaxOffsetY = Abs(.aTop)
End If
End With
Next
If MaxOffsetX > 0 Or MaxOffsetY > 0 Then
For imgCount = 0 To UBound(aniFrames)
With aniFrames(imgCount)
.aLeft = .aLeft + MaxOffsetX
.aTop = .aTop + MaxOffsetY
End With
Next
End If
m_contador = 0
LoadGif = True
Exit Function
ErrHandler:
MsgBox "Error No. " & Err.Number & " when reading file", vbCritical
If fNum Then Close #fNum
m_contador = -1
cleargif
LoadGif = False
End Function
Public Function ConvertHimetrix2Pixels(vHiMetrix As Long, byWidth As Boolean) As Long
If byWidth Then
ConvertHimetrix2Pixels = vHiMetrix * 1440 / 2540 / Screen.TwipsPerPixelX
Else
ConvertHimetrix2Pixels = vHiMetrix * 1440 / 2540 / Screen.TwipsPerPixelY
End If
End Function
Public Function ConvertPixels2Himetrix(vPixels As Long, byWidth As Boolean) As Long
If byWidth Then
ConvertPixels2Himetrix = vPixels / 1440 * 2540 * Screen.TwipsPerPixelX
Else
ConvertPixels2Himetrix = vPixels / 1440 * 2540 * Screen.TwipsPerPixelY
End If
End Function
Private Sub CreateBackBuffImg(cX As Long, cY As Long, Form As Object)
Dim bkBuffDC As Long, bkBuffBmp As Long, oldBmp As Long
Dim destWidth As Long, destHeight As Long
destWidth = Form.picAni.Width / Screen.TwipsPerPixelX
destHeight = Form.picAni.Height / Screen.TwipsPerPixelY
Form.picAni.Cls
If Not picBkBuff Is Nothing Then Set picBkBuff = Nothing
If cX > destWidth Then cX = destWidth
If cY > destHeight Then cY = destHeight
On Error Resume Next ' want a message box if error occurs here
With updateRect
.Left = (destWidth - cX) \ 2
.Top = (destHeight - cY) \ 2
.Right = .Left + cX - 1
.Bottom = .Top + cY - 1
bkBuffDC = CreateCompatibleDC(gif.hdc)
bkBuffBmp = CreateCompatibleBitmap(Form.hdc, cX, cY)
oldBmp = SelectObject(bkBuffDC, bkBuffBmp)
gif.picAni.Picture.Render bkBuffDC + 0, 0, 0, cX + 0, cY + 0, _
Form.ScaleX(.Left, vbPixels, vbHimetric), _
Form.ScaleY(destHeight - .Top, vbPixels, vbHimetric), _
Form.ScaleX(cX, vbPixels, vbHimetric), _
-Form.ScaleY(cY, vbPixels, vbHimetric), ByVal 0&
End With
If Err Then MsgBox Err.Description 'for testing only
SelectObject bkBuffDC, oldBmp
DeleteDC bkBuffDC
Set picBkBuff = HandleToPicture(bkBuffBmp, True)
End Sub
Private Function HandleToPicture(ByVal hHandle As Long, isBitmap As Boolean) As Picture
On Error GoTo ExitRoutine
Dim pic As PICTDESC
Dim guid(0 To 3) As Long
pic.cbSize = Len(pic)
If isBitmap Then pic.pictType = vbPicTypeBitmap Else pic.pictType = vbPicTypeIcon
pic.hIcon = hHandle
guid(0) = &H7BF80980
guid(1) = &H101ABF32
guid(2) = &HAA00BB8B
guid(3) = &HAB0C3000
OleCreatePictureIndirect pic, guid(0), True, HandleToPicture
ExitRoutine:
End Function
'Public Function redraw(ByVal hwnd As Long, ByRef lprcUpdate As RECT)
' RedrawWindow hwnd, lprcUpdate, ByVal 0, 1
'End Function
Public Sub cleargif()
Erase aniFrames
End Sub
Public Function pic(index As Integer)
Set pic = aniFrames(index).aPic
End Function
Public Function picc() As StdPicture
Set picc = aniFrames(m_contador).aPic
End Function
Public Function picPicture() As Picture
Set picPicture = HandleToPicture(aniFrames(m_contador).aPic, True)
End Function
Public Sub nextgif()
If m_contador = UBound(aniFrames) Then m_contador = -1
m_contador = m_contador + 1
End Sub
Public Function interval(index As Integer) As Integer
interval = aniFrames(index).aInterval
End Function
Public Function contador() As Integer
contador = m_contador
End Function
Public Function count() As Integer
count = UBound(aniFrames)
End Function
Private Sub Class_Terminate()
m_contador = -1
cleargif
End Sub
Public gif As clsGif
Set gif = New clsGif
gif.LoadGif "ruta gif"
y tanto pic como picc devuelve un stdpicture
funciona perfectamente para un image control o picturebox
pero no me funciona en un systray claro esta que para hacer la prueba seria mostrar la primera imagen y luego ya con un timer mostrar las siguientes pero de eso ya me encargo yo.
un saludo
Mostrar Mensajes