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