[Source] Efecto Luvia de TV

[LeandroA]

Hola como parte de mi aburrimiento hice este módulo para crear un efecto lluvia de TV, no se si tenga alguna utilidad para alguien pero bueno es para ir aprendiendo un poco mas.

Módulo

Código (vb) [Seleccionar] Expandir


Option Explicit
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
Private Declare Function waveOutOpen Lib "winmm.dll" (lphWaveOut As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function waveOutPrepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutWrite Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Private Declare Function waveOutReset Lib "winmm.dll" (ByVal hWaveOut As Long) As Long

Private Const WHDR_DONE = &H1
Private Const WAVE_MAPPER = -1&

Private Type WAVEHDR
    lpData As Long
    dwBufferLength As Long
    dwBytesRecorded As Long
    dwUser As Long
    dwFlags As Long
    dwLoops As Long
    lpNext As Long
    Reserved As Long
End Type

Private Type WAVEFORMATEX
    wFormatTag As Integer
    nChannels As Integer
    nSamplesPerSec As Long
    nAvgBytesPerSec As Long
    nBlockAlign As Integer
    wBitsPerSample As Integer
    cbSize As Integer
End Type

Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal Hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private hWaveOut As Long
Private bStop As Boolean

Public Sub StopAnimation()
    bStop = True
    If hWaveOut Then waveOutReset hWaveOut
End Sub

Public Sub Play(ByVal Hdc As Long, Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long)
    Dim OutFormat As WAVEFORMATEX
    Dim lngBufferSize As Long
    Dim Rec As RECT
    Dim bData() As Byte
    Dim wvhdr As WAVEHDR
    Dim i As Long

    With OutFormat
        .wFormatTag = 1
        .nSamplesPerSec = 8000
        .wBitsPerSample = 16
        .nChannels = 1
        .nBlockAlign = 2
        .nAvgBytesPerSec = 16000
        .cbSize = Len(OutFormat)
    End With
   
    If waveOutOpen(hWaveOut, WAVE_MAPPER, OutFormat, 0, 0, 0) = 0 Then
   
        bStop = False
        lngBufferSize = 16000& * 30&
       
        ReDim bData(lngBufferSize)
       
        For i = 0 To lngBufferSize - 1
            bData(i) = Int((255 + 1) * Rnd())
        Next
           
        With wvhdr
            .lpData = VarPtr(bData(0))
            .dwBufferLength = lngBufferSize
        End With
       
        With Rec
            .Left = Left
            .Top = Top
            .Right = Left + Width
            .Bottom = Top + Height
        End With
   
        If waveOutPrepareHeader(hWaveOut, wvhdr, Len(wvhdr)) = 0 Then

            While bStop = False
                If waveOutWrite(hWaveOut, wvhdr, Len(wvhdr)) = 0 Then
                    While ((wvhdr.dwFlags And WHDR_DONE) <> WHDR_DONE)
                        Draw Hdc, Rec
                        DoEvents
                        Sleep 10
                    Wend
                End If
            Wend
           
            waveOutUnprepareHeader hWaveOut, wvhdr, Len(wvhdr)
       
        End If
   
        waveOutClose hWaveOut
    End If
       
    hWaveOut = 0
       
End Sub

Private Sub Draw(Hdc As Long, R As RECT)
    Dim hBitmap As Long, mBrush As Long
    Dim PicBits() As Byte, BytesPerLine As Long
    Dim i As Long, lColor As Byte
    Dim W As Long, H As Long
   
   
    W = (150 * Rnd() + 100)
    H = (150 * Rnd() + 100)
   
    BytesPerLine = (W * 3 + 3) And &HFFFFFFFC
       
    ReDim PicBits(1 To BytesPerLine * H * 3) As Byte
       
    For i = 1 To UBound(PicBits) - 4 Step 4
        lColor = Int((255 + 1) * Rnd())
        PicBits(i) = lColor
        PicBits(i + 1) = lColor
        PicBits(i + 2) = lColor
    Next
   
    hBitmap = CreateBitmap(W, H, 1, 32, PicBits(1))

    mBrush = CreatePatternBrush(hBitmap)
   
    FillRect Hdc, R, mBrush

    DeleteObject mBrush
    DeleteObject hBitmap

End Sub


En un formulario con dos botones

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Sub Form_Load()
    Command1.Caption = "Play"
    Command2.Caption = "Stop"
End Sub

Private Sub Command1_Click()
    Call Play(Me.Hdc, 0, 0, Me.ScaleWidth / Screen.TwipsPerPixelX, Me.ScaleHeight / Screen.TwipsPerPixelY)
End Sub

Private Sub Command2_Click()
    StopAnimation
End Sub

Private Sub Form_Unload(Cancel As Integer)
    StopAnimation
End Sub

[Psyke1]

Jajajajaja
Lo clavaste!
Pensé algo asi hace tiempo, pero usando SetPixel(), y más simple.
A mi si que me sirve, gracias pollo!

DoEvents!

[agus0]

@LeandroA :  Gracias por el aporte ya le vamos a encontrar utilidad

Jajajajaja
Lo clavaste!
Pensé algo asi hace tiempo, pero usando SetPixel(), y más simple.
A mi si que me sirve, gracias pollo!

DoEvents!

Ahora Todos nos identificamos con un animal... u encima justo hace un Tiempo puse a Tux en Mi Avatar.. Cagué ahora me van a decir PingUino

[Elemental Code]

MATOOOOOOO!!!!!!

Esta fantastico el efecto.

jeje, con ruidito y todo.

[79137913]

HOLA!!!

GENIAL!!!!!

ME SIRVE UN MONTON!!!!!

GRACIAS POR LEER!!!