Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: yokesee 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
-
En el Systray, solo se pueden poner iconos, no puedes poner un control image, ni picturebox, ni un control de usuario...
La razón de que sólo se admitan iconos, obedece a que los iconos admiten transparencia e incluyen en la propia imagen la máscara y se usa la técnica de 3 pasos mediante XOR, para crar la transparencia con el propio icono.
Al pasar una imagen para el systray, el sistema comprueba el tipo de imagen y solo si es del tipo: vbPicTypeIcon lo coloca en la barra de tareas....
Tendrás seguramente una rutina llamada 'AddIcono', que añade el icono al sysTray cuando arrancas la aplicación y un 'DeleteIcono' cuando termina... por tanto, si necesitas animarlo, lo que te falta es una propiedad para cambiar el icono, controlado por un timer.
Así disponiendo de varios iconos, al vencer el crono del timer, cambia el icono...
Sería algo así:
Private Sub Timer1_Timer()
Set Objeto.IconoSystray = Iconos(numActual) ' esto se supone un array o colección de iconos...
End sub
Public Property Get IconoSysTray() As IPictureDisp
Set IconoSysTray = p_IconoTray ' Return Icon value
End Property
Public Property Set IconoSysTray(byref Icono As IPictureDisp)
Dim NIcoD As NOTIFYICONDATA
If Not (Icono Is Nothing) Then
If (Icono.Type = vbPicTypeIcon) Then ' SOLO cuando es un icono... (y nunca más).
If (YaEnSystray = True) Then
NIcoD.uID = gTrayId ' UID por cada HWND y mensajes de callback.
NIcoD.hwnd = gTrayHwnd
NIcoD.hIcon = Icono.Handle
NIcoD.uFlags = NIF_ICON
NIcoD.cbSize = LenB(NIcoD )
call ShellNotifyIcon(NIM_MODIFY, NIcoD )
Else
Set Picture = Icono ' comentar si no fuera un usercontrol...
End If
Set p_IconoTray = Icono
PropertyChanged "IconoSysTray"
End If
End If
End Property
' por supuesto el timer se activará con:
timer1.enabled = YaEnSystray
'Y esa variable, se asigna a true desde el método 'AddIcono'
' y a false desde el método 'DeleteIcono'
-
gracias NEBIRE por contestar.
habria alguna manera de convertir un archivo bmp en vbPicTypeIcon por que los stdpictures se pueden guardar como bmp y asi lo extraeria y lo convertiria y luego lo mostraria.
e encontrado este modulo pero no lo entiendo mucho pone que convierte de bmp a ico pero con mask.
http://www.thevbzone.com/modBitmap.bas (http://www.thevbzone.com/modBitmap.bas)
un saludo
-
Claro, te lo miro mañana, aquí ya es muy tarde...
-
gracias ya conseguí hacer lo con estos módulos
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=44216&lngWId=1 (http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=44216&lngWId=1)
-
Ok, me alegro...
considera sin embargo, que si las imágenes de procedencia Gif, son muy grandes, no funcionará bien, ya que cuando se escalan imágenes que tienen trasnparencia aparecen uno de dos problemas:
- Si, se usa un método de eliminar líneas (como el método paintpicture de VB), el color transparente sigue siendo el color transparente y no aparecen colores distintos de los que tiene la imagen original, el problema es la pérdida de calidad y si el factor de escala de reducción es muy elevado, la imagen queda muy aserrada, si contiene líneas inclinadas y/o curvas.
- Si se usa un método de interpolación, el color transparente se fusiona con el color adhiacente, quedando artefactos en el perímetro de las zonas transparentes, muy desagradables. Puede limitarse ese efecto si el color transparente varía muy poco respecto del color con el que se ha de fusionar, pero esto es muy dependiente del contenido que tenga laimagen, no puede aplicarse a todas.
Si el tamaño de origen del gif, es muy similar al del icono resultante, es perfectamente válido, si no, te recomiendo generar iconos nuevos, aunque sea operando el gif, en un programa de imagen.
-
muchas gracias NEBIRE lo tendré encuenta todo lo que me has dicho
gracias por enseñarme cosas nuevas siempre se aprende algo
un saludo