Ejemplos usando el Api de windows para Visual basic

208 - Efecto de animación en imágenes con el api AlphaBlend

Ejemplo que usa la función del api AlphaBlend para visualizar imágenes con transparencia , generando un efecto de transición entre cada una

El formulario es como la siguiente imagen

vista del formulario de ejemplo con los controles para el proyecto de visual basic

Como se ve en el gráfico, en la parte izquierda hay unos controles FileListbox y dirlistbox para seleccionar los gráficos, y entre cada cambio de imagen, mediante el uso de un timer, se va copiando mediante el api alphablend la imagen con la transparencia, desde el valor mas bajo ( transparencia = 0) hasta que la imagen sea completamente visible ( transparencia = 255 ) generando el efecto

En el formulario se utilizann dos controles picturebox, uno está oculto y es el que tiene la imagen a copiar en el picture que está visible

Nota: Si la imagen a copiar, es decir el picturebox es muy grande, es posible que la animación se lentifique. Por eso no usarlo con un picturebox que ocupe toda o casi el área de la pantalla. ( para ver este efecto de lentitud, probarlo con el formulario maximizado )

Controles

Agegar en el formulario los siguiente controles

1 - Un control DrivelistBox
2 - Un DirListbox
3 - Un FileListBox
4 - Un picturebox llamado picture1
5 - Un control timer llamado timer1
6 - Un módulo bas

Código fuente en el formulario

Option Explicit ' valor para el valor de transparencia Dim Transparencia As Byte Dim PicOrigen As PictureBox Private Sub File1_Click() '... Si se está ejecutando el timer If Timer1.Enabled Then ' lo desactiva Timer1.Enabled = False ' reestablece el valor para la transparencia Transparencia = 0 End If ' Dibuja la imagen a escala en el picture invisible Call Dibujar_Imagen(LoadPicture(Dir1.Path & "\" & File1.FileName), PicOrigen) ' Activa el timer que tiene el código para _ copiar la imagen con el api AlphaBlend Timer1.Enabled = True Exit Sub End Sub Private Sub Form_Load() Timer1.Enabled = False Timer1.Interval = 25 ' Crea un picturebox en tiempo de ejecución que contiene la imagen a copiar Set PicOrigen = Me.Controls.Add("vb.Picturebox", "Pic1") ' Picturebox oculto With PicOrigen .AutoRedraw = True .AutoSize = True .ScaleMode = vbPixels End With 'Picturebox donde se visualizan las imagenes With Picture1 .ScaleMode = vbPixels ' El modo de persistencia debe estar desactivado .AutoRedraw = False End With ' REdimensiona el picturebox al picturebox oculto Picture1_Resize On Error Resume Next File1.Pattern = "*.bmp;*.gif;*.jpg;*.jpeg" Dir1.Path = "c:\" Drive1 = "c:\" Dir1.Path = "c:\windows\web\wallpaper" Me.Caption = "Ejemplo de animación de ventanas y controles " Me.Caption = "Visualizador de imágenes con efecto de transparencia" End Sub Private Sub Dir1_Change() File1 = Dir1 End Sub Private Sub Drive1_Change() Dir1 = Drive1 End Sub Private Sub Form_Resize() On Local Error Resume Next ' posiciona y redimensiona el Drivelistbox Drive1.Move 10, 10, 2500 ' posiciona y redimensiona el Dirlistbox Dir1.Move 10, Drive1.Top + Drive1.Height + 10, 2500, 2500 ' Redimensiona el Dilelistbox y el picturebox File1.Move 10, Dir1.Top + Dir1.Height + 10, 2500, _ Me.ScaleHeight - (Dir1.Height + Drive1.Height + 50) Picture1.Move File1.Left + File1.Width + 50, 0, _ (Me.ScaleWidth - File1.Width), Me.ScaleHeight End Sub Private Sub Form_Unload(Cancel As Integer) If Not PicOrigen Is Nothing Then Set PicOrigen = Nothing End If End Sub Private Sub Picture1_Resize() ' cuando cambia el tamaño del picture1, _ se cambia también el tamaño del picture oculto PicOrigen.Width = Picture1.Width PicOrigen.Height = Picture1.Height End Sub Private Sub Timer1_Timer() ' Copia la imagen con transparencia ( le pasa los dos pic _ turebox y el nivel de transparente ) Call Copiar_Con_Transparencia(PicOrigen, Picture1, Transparencia) ' Si llegó al límite de transparencia sale del timer y reestablece el valor del transparent If Transparencia >= 255 Then Transparencia = 0 Timer1.Enabled = False Exit Sub End If ' aumenta el valor de la transparencia Transparencia = Transparencia + 1 End Sub

Código fuente en el módulo bas

Option Explicit ' Declaraciones del Api para copiar la imagen a escala en el picturebox '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Declare Function StretchBlt Lib "gdi32" (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 dwRop As Long) _ As Long Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, _ ByVal nStretchMode As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal _ hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long ' Declaraciones del api para copiar la imagen transparente '******************************************************************************** Private Type BLENDFUNCTION BlendOp As Byte BlendFlags As Byte SourceConstantAlpha As Byte AlphaFormat As Byte End Type Private Declare Function AlphaBlend Lib "msimg32.dll" ( _ ByVal hdc As Long, _ ByVal lInt As Long, _ ByVal lInt As Long, _ ByVal lInt As Long, _ ByVal lInt As Long, _ ByVal hdc As Long, _ ByVal lInt As Long, _ ByVal lInt As Long, _ ByVal lInt As Long, _ ByVal lInt As Long, _ ByVal BLENDFUNCT As Long) As Long Private Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _ Destination As Any, _ Source As Any, _ ByVal Length As Long) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Función que dibuja la imagen a escala en los picturebox ' recibe como parámetro la imagen ( tipo picture) y el picture destino ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Dibujar_Imagen(Img As StdPicture, Pic As Object) Dim PLeft As Long Dim PTop As Long Dim ReqWidth As Long Dim ReqHeight As Long Dim HScale As Double Dim VScale As Double Dim MyScale As Double Dim Ancho_Imagen As Long Dim Alto_Imagen As Long Dim SourceHDC As Long 'Escala en pixles Pic.ScaleMode = vbPixels ' borra la imagen del picturebox Pic.Cls ' Convierte el valor de las medidas ( Himetric a pixeles ) Ancho_Imagen = Pic.ScaleX(Img.Width, vbHimetric, vbPixels) Alto_Imagen = Pic.ScaleY(Img.Height, vbHimetric, vbPixels) ' Escala horizontal y vertical de la imagen HScale = Pic.ScaleWidth / (Ancho_Imagen) VScale = Pic.ScaleHeight / (Alto_Imagen) ' Obtiene el mayor MyScale = IIf(VScale >= HScale, HScale, VScale) ReqWidth = Ancho_Imagen * MyScale ReqHeight = Alto_Imagen * MyScale 'Posición izquierda y Arriba, para centrar la imagen en el picturebox PLeft = (Pic.ScaleWidth - ReqWidth) / 2 PTop = (Pic.ScaleHeight - ReqHeight) / 2 SourceHDC = CreateCompatibleDC(0) DeleteObject SelectObject(SourceHDC, Img.Handle) SetStretchBltMode Pic.hdc, vbPaletteModeNone ' Si es un ícono usa PaintPicture, si no StretchBlt If Img.Type = 3 Then Pic.PaintPicture Img, PLeft, PTop, ReqWidth, ReqHeight Else ' Dibuja el gráfico en el Picture StretchBlt Pic.hdc, PLeft, PTop, ReqWidth, ReqHeight, _ SourceHDC, 0, 0, Ancho_Imagen, Alto_Imagen, vbSrcCopy DeleteDC SourceHDC End If End Function ' función que mezcla la imagen en el picturebox con transparencia '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Function Copiar_Con_Transparencia(Pic_Origen As PictureBox, _ PicDestino As PictureBox, _ Transparent As Byte) ' Estructura que utiliza el api AlphaBlend Dim BF As BLENDFUNCTION Dim lBF As Long With BF .BlendOp = 0 .BlendFlags = 0 ' acá se define el valor para la transparencia .SourceConstantAlpha = Transparent .AlphaFormat = 0 End With RtlMoveMemory lBF, BF, 4 ' Dibuja el gráfico con la transparencia AlphaBlend PicDestino.hdc, 0, 0, PicDestino.ScaleWidth, PicDestino.ScaleHeight, _ Pic_Origen.hdc, 0, 0, Pic_Origen.ScaleWidth, Pic_Origen.ScaleHeight, lBF End Function

Recursos Visual basic - Enlaces relacionados

Buscar en Recursos vb