Título: [Source] Efecto Luvia de TV
Publicado por: LeandroA en 14 Diciembre 2010, 01:14 am
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
Título: Re: [Source] Efecto Luvia de TV
Publicado por: Psyke1 en 14 Diciembre 2010, 01:48 am
Jajajajaja :laugh: Lo clavaste! :D Pensé algo asi hace tiempo, pero usando SetPixel(), y más simple. :silbar: A mi si que me sirve, gracias pollo! :-*
DoEvents! :P
Título: Re: [Source] Efecto Luvia de TV
Publicado por: agus0 en 14 Diciembre 2010, 02:33 am
@LeandroA : Gracias por el aporte ya le vamos a encontrar utilidad Jajajajaja :laugh: Lo clavaste! :D Pensé algo asi hace tiempo, pero usando SetPixel(), y más simple. :silbar: A mi si que me sirve, gracias pollo! :-*
DoEvents! :P
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
Título: Re: [Source] Efecto Luvia de TV
Publicado por: Elemental Code en 14 Diciembre 2010, 02:41 am
MATOOOOOOO!!!!!!
Esta fantastico el efecto.
jeje, con ruidito y todo.
Título: Re: [Source] Efecto Luvia de TV
Publicado por: 79137913 en 14 Diciembre 2010, 11:50 am
HOLA!!!
GENIAL!!!!!
ME SIRVE UN MONTON!!!!!
GRACIAS POR LEER!!!
|