Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: LeandroA en Diciembre 13, 2010, 09:18:01 pm
-
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
-
Che si cambias de 8kHz
.nSamplesPerSec = 8000
a 41kHz, queda mucho mas vivo:
.nSamplesPerSec = 41000
saludos
-
Muy bueno lea.. jejeje
-
jaja Muy Bueno, ahora a interntar a hacer la "estatica" de la tv, y se vera bien en un "About" xD
-
Muy Bueno, ahora solo falta el
(http://www.gotechbench.com/images/SMPTE.gif)
y ya tenemos una tv en vb! :D
-
Jajajajajajajajajajaja... Pero unos 2MIN luego de tanto SHHHHHHHHHHHHHHHHHHHHHHHHHHHHH
-
jaja y porque no esto es mas facil :D
Option Explicit
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 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 CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) 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 StopSMPTE()
bStop = True
If hWaveOut Then waveOutReset hWaveOut
End Sub
Public Sub PlaySMPTE(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 = 3000
.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& * 5
ReDim bData(lngBufferSize)
For i = 0 To lngBufferSize - 1 Step 3
bData(i) = 100
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)
DrawSMPTE Hdc, Rec
DoEvents
Sleep 1
Wend
End If
Wend
waveOutUnprepareHeader hWaveOut, wvhdr, Len(wvhdr)
End If
waveOutClose hWaveOut
End If
hWaveOut = 0
End Sub
Public Sub DrawSMPTE(Hdc As Long, R As RECT)
Dim hBrush As Long
Dim i As Long
Dim W As Long, H As Long
Dim Rec As RECT
Dim v As Variant
v = Array(15, 14, 11, 10, 13, 12, 9)
W = (R.Right - R.Left) / 7
H = (R.Bottom - R.Top)
Rec.Top = R.Top
Rec.Bottom = R.Bottom - (H / 8)
For i = 0 To 6
hBrush = CreateSolidBrush(QBColor(v(i)))
Rec.Left = W * i
Rec.Right = Rec.Left + W
FillRect Hdc, Rec, hBrush
DeleteObject hBrush
Next
Rec.Top = Rec.Bottom
Rec.Bottom = R.Bottom
For i = 0 To 6
If i Mod 2 Then
hBrush = CreateSolidBrush(0)
Else
hBrush = CreateSolidBrush(QBColor(v(6 - i)))
End If
Rec.Left = W * i
Rec.Right = Rec.Left + W
FillRect Hdc, Rec, hBrush
DeleteObject hBrush
Next
End Sub
Private Sub Form_Load()
Command1.Caption = "Play"
Command2.Caption = "Stop"
End Sub
Private Sub Command1_Click()
Call PlaySMPTE(Me.Hdc, 0, 0, Me.ScaleWidth / Screen.TwipsPerPixelX, Me.ScaleHeight / Screen.TwipsPerPixelY)
End Sub
Private Sub Command2_Click()
StopSMPTE
End Sub
Private Sub Form_Unload(Cancel As Integer)
StopSMPTE
End Sub
-
JAJAJAJAJAJA XD te pasas Leandro :P
Esto en la camarita web mientras carga.... , y queda de pelicula :)
-
Como estoy algo al pedo y aburrido hice el clasico CountDown
no utilize apis para las brochas por no renegar.
(http://i4.ytimg.com/vi/KH1NYhTGNCA/default.jpg) (http://www.youtube.com/watch?v=HzTdxiixjrk&feature=related)
En un formulario
Option Explicit
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 Polygon Lib "gdi32" (ByVal Hdc As Long, lpPoint As Any, ByVal nCount As Long) As Long
Private Declare Function Ellipse Lib "gdi32.dll" (ByVal Hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DrawText Lib "user32.dll" Alias "DrawTextA" (ByVal Hdc As Long, ByVal lpStr As String, ByVal nCount As Long, ByRef lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const DT_CENTER As Long = &H1
Private Const DT_VCENTER As Long = &H4
Private Const DT_SINGLELINE As Long = &H20
Private Sub CountDown(ByVal lStarCount As Long, lEndCount As Long)
Dim Poly(1 To 10) As POINTAPI
Dim Rec As RECT
Dim i As Long, j As Long
Dim W As Long, H As Long
With Me
.ScaleMode = vbPixels
.AutoRedraw = True
W = .ScaleWidth
H = .ScaleHeight
Rec.Right = W
Rec.Bottom = H
.Font.Name = "Tahoma"
.FontSize = (W + H) / 4
.BackColor = &HCCCCCC
Poly(1).x = W / 2
Poly(1).y = H / 2
Poly(2).x = W / 2
Poly(2).y = 0
Poly(3).x = W
Poly(3).y = 0
Poly(4).x = W
Poly(4).y = H / 2
Poly(5).x = W
Poly(5).y = H
Poly(6).x = W / 2
Poly(6).y = H
Poly(7).x = 0
Poly(7).y = H
Poly(8).x = 0
Poly(8).y = H / 2
Poly(10) = Poly(2)
For j = lStarCount To lEndCount Step -1
BeepEx
For i = 2 To 10
.Cls
.ForeColor = vbBlack
.FillColor = &H999999
.FillStyle = 0
Polygon Me.Hdc, Poly(1), i
DrawText .Hdc, j, -1, Rec, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
.FillStyle = 1
.DrawWidth = 2
Me.Line (0, H / 2)-(W, H / 2)
Me.Line (W / 2, 0)-(W / 2, H)
.ForeColor = vbWhite
.DrawWidth = 3
Ellipse .Hdc, W / 16, H / 16, W - W / 16, H - H / 16
Ellipse .Hdc, W / 8, H / 8, W - W / 8, H - H / 8
.Refresh
DoEvents
Sleep 110
Next
Next
End With
End Sub
Public Sub BeepEx()
Dim OutFormat As WAVEFORMATEX
Dim lngBufferSize As Long
Dim Rec As RECT
Dim bData() As Byte
Dim wvhdr As WAVEHDR
Dim i As Long
Dim hWaveOut As Long
With OutFormat
.wFormatTag = 1
.nSamplesPerSec = 3000
.wBitsPerSample = 16
.nChannels = 1
.nBlockAlign = 2
.nAvgBytesPerSec = 6000
.cbSize = Len(OutFormat)
End With
If waveOutOpen(hWaveOut, WAVE_MAPPER, OutFormat, 0, 0, 0) = 0 Then
lngBufferSize = 300
ReDim bData(lngBufferSize)
For i = 0 To lngBufferSize - 1 Step 3
bData(i) = 100
Next
With wvhdr
.lpData = VarPtr(bData(0))
.dwBufferLength = lngBufferSize
End With
If waveOutPrepareHeader(hWaveOut, wvhdr, Len(wvhdr)) = 0 Then
If waveOutWrite(hWaveOut, wvhdr, Len(wvhdr)) = 0 Then
While ((wvhdr.dwFlags And WHDR_DONE) <> WHDR_DONE)
Wend
End If
waveOutUnprepareHeader hWaveOut, wvhdr, Len(wvhdr)
End If
waveOutClose hWaveOut
End If
hWaveOut = 0
Erase bData
End Sub
Private Sub Form_Load()
With Me
.Width = 10000
.Height = 10000
.Show
End With
Call CountDown(5, 1)
Unload Me
End Sub
-
Me dejan sin aliento y veo lo pequeño que soy y el largo camino que aun me falta por recorrer. Gracias tigres.