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
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
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
Mostrar Mensajes
