elhacker.net cabecera Bienvenido(a), Visitante. Por favor Ingresar o Registrarse
¿Perdiste tu email de activación?.

 

 


Tema destacado: Introducción a Git (Primera Parte)


+  Foro de elhacker.net
|-+  Programación
| |-+  Programación General
| | |-+  .NET (C#, VB.NET, ASP)
| | | |-+  Programación Visual Basic (Moderadores: LeandroA, seba123neo)
| | | | |-+  [Source] Efecto Luvia de TV
0 Usuarios y 1 Visitante están viendo este tema.
Páginas: [1] Ir Abajo Respuesta Imprimir
Autor Tema: [Source] Efecto Luvia de TV  (Leído 2,596 veces)
LeandroA
Moderador
***
Desconectado Desconectado

Mensajes: 760


www.leandroascierto.com


Ver Perfil WWW
[Source] Efecto Luvia de TV
« 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
Código
  1. Option Explicit
  2. 'Autor: Leandro Ascierto
  3. 'Web: www.leandroascierto.com.ar
  4. 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
  5. Private Declare Function waveOutPrepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
  6. Private Declare Function waveOutWrite Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
  7. Private Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
  8. Private Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
  9. Private Declare Function waveOutReset Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
  10.  
  11. Private Const WHDR_DONE = &H1
  12. Private Const WAVE_MAPPER = -1&
  13.  
  14. Private Type WAVEHDR
  15.    lpData As Long
  16.    dwBufferLength As Long
  17.    dwBytesRecorded As Long
  18.    dwUser As Long
  19.    dwFlags As Long
  20.    dwLoops As Long
  21.    lpNext As Long
  22.    Reserved As Long
  23. End Type
  24.  
  25. Private Type WAVEFORMATEX
  26.    wFormatTag As Integer
  27.    nChannels As Integer
  28.    nSamplesPerSec As Long
  29.    nAvgBytesPerSec As Long
  30.    nBlockAlign As Integer
  31.    wBitsPerSample As Integer
  32.    cbSize As Integer
  33. End Type
  34.  
  35. Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
  36. Private Declare Function FillRect Lib "user32" (ByVal Hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  37. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  38. 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
  39. Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
  40.  
  41. Private Type RECT
  42.    Left As Long
  43.    Top As Long
  44.    Right As Long
  45.    Bottom As Long
  46. End Type
  47.  
  48. Private hWaveOut As Long
  49. Private bStop As Boolean
  50.  
  51. Public Sub StopAnimation()
  52.    bStop = True
  53.    If hWaveOut Then waveOutReset hWaveOut
  54. End Sub
  55.  
  56. Public Sub Play(ByVal Hdc As Long, Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long)
  57.    Dim OutFormat As WAVEFORMATEX
  58.    Dim lngBufferSize As Long
  59.    Dim Rec As RECT
  60.    Dim bData() As Byte
  61.    Dim wvhdr As WAVEHDR
  62.    Dim i As Long
  63.  
  64.    With OutFormat
  65.        .wFormatTag = 1
  66.        .nSamplesPerSec = 8000
  67.        .wBitsPerSample = 16
  68.        .nChannels = 1
  69.        .nBlockAlign = 2
  70.        .nAvgBytesPerSec = 16000
  71.        .cbSize = Len(OutFormat)
  72.    End With
  73.  
  74.    If waveOutOpen(hWaveOut, WAVE_MAPPER, OutFormat, 0, 0, 0) = 0 Then
  75.  
  76.        bStop = False
  77.        lngBufferSize = 16000& * 30&
  78.  
  79.        ReDim bData(lngBufferSize)
  80.  
  81.        For i = 0 To lngBufferSize - 1
  82.            bData(i) = Int((255 + 1) * Rnd())
  83.        Next
  84.  
  85.        With wvhdr
  86.            .lpData = VarPtr(bData(0))
  87.            .dwBufferLength = lngBufferSize
  88.        End With
  89.  
  90.        With Rec
  91.            .Left = Left
  92.            .Top = Top
  93.            .Right = Left + Width
  94.            .Bottom = Top + Height
  95.        End With
  96.  
  97.        If waveOutPrepareHeader(hWaveOut, wvhdr, Len(wvhdr)) = 0 Then
  98.  
  99.            While bStop = False
  100.                If waveOutWrite(hWaveOut, wvhdr, Len(wvhdr)) = 0 Then
  101.                    While ((wvhdr.dwFlags And WHDR_DONE) <> WHDR_DONE)
  102.                        Draw Hdc, Rec
  103.                        DoEvents
  104.                        Sleep 10
  105.                    Wend
  106.                End If
  107.            Wend
  108.  
  109.            waveOutUnprepareHeader hWaveOut, wvhdr, Len(wvhdr)
  110.  
  111.        End If
  112.  
  113.        waveOutClose hWaveOut
  114.    End If
  115.  
  116.    hWaveOut = 0
  117.  
  118. End Sub
  119.  
  120. Private Sub Draw(Hdc As Long, R As RECT)
  121.    Dim hBitmap As Long, mBrush As Long
  122.    Dim PicBits() As Byte, BytesPerLine As Long
  123.    Dim i As Long, lColor As Byte
  124.    Dim W As Long, H As Long
  125.  
  126.  
  127.    W = (150 * Rnd() + 100)
  128.    H = (150 * Rnd() + 100)
  129.  
  130.    BytesPerLine = (W * 3 + 3) And &HFFFFFFFC
  131.  
  132.    ReDim PicBits(1 To BytesPerLine * H * 3) As Byte
  133.  
  134.    For i = 1 To UBound(PicBits) - 4 Step 4
  135.        lColor = Int((255 + 1) * Rnd())
  136.        PicBits(i) = lColor
  137.        PicBits(i + 1) = lColor
  138.        PicBits(i + 2) = lColor
  139.    Next
  140.  
  141.    hBitmap = CreateBitmap(W, H, 1, 32, PicBits(1))
  142.  
  143.    mBrush = CreatePatternBrush(hBitmap)
  144.  
  145.    FillRect Hdc, R, mBrush
  146.  
  147.    DeleteObject mBrush
  148.    DeleteObject hBitmap
  149.  
  150. End Sub
  151.  

En un formulario con dos botones
Código
  1. Option Explicit
  2.  
  3. Private Sub Form_Load()
  4.    Command1.Caption = "Play"
  5.    Command2.Caption = "Stop"
  6. End Sub
  7.  
  8. Private Sub Command1_Click()
  9.    Call Play(Me.Hdc, 0, 0, Me.ScaleWidth / Screen.TwipsPerPixelX, Me.ScaleHeight / Screen.TwipsPerPixelY)
  10. End Sub
  11.  
  12. Private Sub Command2_Click()
  13.    StopAnimation
  14. End Sub
  15.  
  16. Private Sub Form_Unload(Cancel As Integer)
  17.    StopAnimation
  18. End Sub




En línea

Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
Re: [Source] Efecto Luvia de TV
« Respuesta #1 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


En línea

agus0


Desconectado Desconectado

Mensajes: 360



Ver Perfil
Re: [Source] Efecto Luvia de TV
« Respuesta #2 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
En línea

Elemental Code


Desconectado Desconectado

Mensajes: 622


Im beyond the system


Ver Perfil
Re: [Source] Efecto Luvia de TV
« Respuesta #3 en: 14 Diciembre 2010, 02:41 am »

MATOOOOOOO!!!!!!

Esta fantastico el efecto.

jeje, con ruidito y todo.
En línea

I CODE FOR $$$
Programo por $$$
Hago tareas, trabajos para la facultad, lo que sea en VB6.0

Mis programas
79137913


Desconectado Desconectado

Mensajes: 1.169


4 Esquinas


Ver Perfil WWW
Re: [Source] Efecto Luvia de TV
« Respuesta #4 en: 14 Diciembre 2010, 11:50 am »

HOLA!!!

GENIAL!!!!!

ME SIRVE UN MONTON!!!!!

GRACIAS POR LEER!!!
En línea

"Como no se puede igualar a Dios, ya he decidido que hacer, ¡SUPERARLO!"
"La peor de las ignorancias es no saber corregirlas"

 79137913                          *Shadow Scouts Team*
Páginas: [1] Ir Arriba Respuesta Imprimir 

Ir a:  

WAP2 - Aviso Legal - Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines