[Source] Efecto Luvia de TV

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

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

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