求一个能实现屏幕水波纹效果的vb代码

求一个能实现屏幕水波纹效果的vb代码~

'3个模块.模块123。一个资源文件。资源文件中放置一个位图标识号1 '*****模块1 Option Explicit ' Window Functions Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Public Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long Public Declare Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long) ' Message Public Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Public Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long Public Declare Fun

什么意思，图片的话直接设置背景，代码文件直接复制

'补模块3文件。一个放不下。
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 渲染子程序，将新的帧数据渲染到 lpDIBitsRender 中
' 算法：
' posx = Wave1(x-1,y)-Wave1(x+1,y)+x
' posy = Wave1(x,y-1)-Wave1(x,y+1)+y
' SourceBmp(x,y) = DestBmp(posx,posy)
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Sub WaveRender(lpWaveObject As WAVE_OBJECT)
Dim dwPosX As Long, dwPosY As Long, dwPtrSource As Long, dwPtrDest As Long, dwFlag As Long
Dim lpWave1 As Long, LineIdx As Long, LinePtr As Long
Dim lpDIBitsSource As Long, lpDIBitsRender As Long
Dim I As Long, J As Long
dwFlag = 0
With lpWaveObject
'Debug.Print "WaveRender " & .dwFlag
If (.dwFlag And F_WO_ACTIVE) = 0 Then Exit Sub
.dwFlag = .dwFlag Or F_WO_NEED_UPDATE
lpWave1 = .lpWave1
LineIdx = .dwWaveByteWidth '像素指针
For I = 1 To .dwBmpHeight - 2
For J = 0 To .dwBmpWidth - 1
'********************************************************************
' PosY=i+像素上1能量-像素下1能量
' PosX=j+像素左1能量-像素右1能量
'********************************************************************
'LineIdx = LineIdx - .dwWaveByteWidth
LinePtr = lpWave1 + LineIdx - .dwWaveByteWidth
pLongPtr(0) = LinePtr
dwPosY = pLong(0)
LinePtr = lpWave1 + LineIdx + .dwWaveByteWidth
pLongPtr(0) = LinePtr
dwPosY = dwPosY - pLong(0) + I

LinePtr = lpWave1 + LineIdx - 4
pLongPtr(0) = LinePtr
dwPosX = pLong(0)
LinePtr = lpWave1 + LineIdx + 4
pLongPtr(0) = LinePtr
dwPosX = dwPosX - pLong(0) + J
If dwPosX < 0 Or dwPosY < 0 Then GoTo Continue
If dwPosX >= .dwBmpWidth Or dwPosY >= .dwBmpHeight Then GoTo Continue
'********************************************************************
' ptrSource = dwPosY * dwDIByteWidth + dwPosX * 3
' ptrDest = i * dwDIByteWidth + j * 3
'********************************************************************
'dwPtrSource = dwPosY * .dwDIByteWidth + (dwPosX + dwPosX * 2)
dwPosX = dwPosX + dwPosX * 2 'dwPosX * 3
dwPtrSource = dwPosY * .dwDIByteWidth + dwPosX
dwPtrDest = I * .dwDIByteWidth + (J + J * 2) 'dwPtrDest = I * .dwDIByteWidth + J * 3
'********************************************************************
' 渲染像素 [ptrDest] = 原始像素 [ptrSource]
'********************************************************************
lpDIBitsSource = .lpDIBitsSource + dwPtrSource
lpDIBitsRender = .lpDIBitsRender + dwPtrDest
If dwPtrSource <> dwPtrDest Then
dwFlag = dwFlag Or 1 '如果存在源像素和目标像素不同，则表示还在活动状态
' Debug.Print dwPtrSource & " SR " & dwPtrDest
'CopyMemory ByVal lpDIBitsRender, ByVal lpDIBitsSource, 3
Call WaveGetPixel(lpDIBitsSource, lpDIBitsRender, .dwDIByteWidth)
Else
CopyMemory ByVal lpDIBitsRender, ByVal lpDIBitsSource, 3
End If
'********************************************************************
' 继续循环
'********************************************************************
Continue:
LineIdx = LineIdx + 4 '像素++ '指针4个字节
Next 'J
Next 'I
SetDIBits .hDcRender, .hBmpRender, 0, .dwBmpHeight, .lpDIBitsRender, .stBmpInfo, DIB_RGB_COLORS
If dwFlag = 0 Then .dwFlag = .dwFlag And (Not F_WO_ACTIVE)
'Debug.Print "WaveRender " & .dwFlag
End With
End Sub

Public Sub WaveUpdateFrame(lpWaveObject As WAVE_OBJECT, ByVal hdc As Long, bIfForce As Boolean)
'Dim ret As Long
With lpWaveObject
If bIfForce = True Then GoTo labUpdate
If (.dwFlag And F_WO_NEED_UPDATE) Then
'ret = SetDIBitsToDevice(.hDcRender, 0, 0, .dwBmpWidth, .dwBmpHeight, 0, 0, 0, .dwBmpHeight, .lpDIBitsRender, .stBmpInfo, DIB_RGB_COLORS)
'ret = SetDIBits(.hDcRender, .hBmpRender, 0, .dwBmpHeight, .lpDIBitsRender, .stBmpInfo, DIB_RGB_COLORS)
'SetDIBits .hDcRender, .hBmpRender, 0, .dwBmpHeight, .lpDIBitsRender, .stBmpInfo, DIB_RGB_COLORS
labUpdate:
BitBlt hdc, 0, 0, .dwBmpWidth, .dwBmpHeight, .hDcRender, 0, 0, SRCCOPY
.dwFlag = .dwFlag And (Not F_WO_NEED_UPDATE)
End If
End With
End Sub

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 扔一块石头
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Sub WaveDropStone(lpWaveObject As WAVE_OBJECT, ByVal dwPosX As Long, ByVal dwPosY As Long, ByVal dwStoneSize As Long, ByVal dwStoneWeight As Long)
Dim dwSize As Long
Dim dwX1 As Long, dwX2 As Long
Dim dwY1 As Long, dwY2 As Long, dwY3 As Long
'Dim dwMaxX As Long, dwMaxY As Long
Dim LinePtr As Long

With lpWaveObject
'Debug.Print "WaveDropStone " & .dwFlag
'********************************************************************
' 计算范围
'********************************************************************
dwSize = dwStoneSize \ &H2 '2 ^ 1
dwX1 = dwPosX + dwSize
dwX2 = dwPosX - dwSize
If (.dwFlag And F_WO_ELLIPSE) Then dwSize = dwSize \ &H2 ' 2 ^ 1
dwY1 = dwPosY + dwSize
dwY2 = dwPosY - dwSize
dwSize = dwStoneSize
If dwSize = 0 Then dwSize = dwSize + 1
'********************************************************************
' 判断范围的合法性
'********************************************************************
If dwX1 + 1 >= .dwBmpWidth Or dwX2 < 1 Or dwY1 + 1 >= .dwBmpHeight Or dwY2 < 1 Then Exit Sub
'********************************************************************
' 将范围内的点的能量置为 dwStoneWeight
'********************************************************************
While dwX2 <= dwX1
dwY3 = dwY2
While dwY3 <= dwY1
'(x-x0)^2+(y-y0)^2<=r^2 就在圆内
If (dwX2 - dwPosX) * (dwX2 - dwPosX) + (dwY3 - dwPosY) * (dwY3 - dwPosY) <= dwSize * dwSize Then
LinePtr = .lpWave1 + (dwY3 * .dwBmpWidth + dwX2) * &H4 '2 ^ 2
pLongPtr(0) = LinePtr
pLong(0) = dwStoneWeight
End If
dwY3 = dwY3 + 1
Wend
dwX2 = dwX2 + 1
Wend
.dwFlag = .dwFlag Or F_WO_ACTIVE
End With

End Sub
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 计算扩散数据、渲染位图、更新窗口、处理特效的定时器过程
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Sub WaveTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
Dim hdc As Long
Dim dwPosX As Long, dwPosY As Long, dwSize As Long, dwWeight As Long
Dim lpWaveObj As Long
'建立模拟指针
Dim pWAVE_OBJECT() As WAVE_OBJECT
Dim pWAVE_OBJECTPtr() As Long
Dim SApWAVE_OBJECT As SAFEARRAY1D
Dim SApWAVE_OBJECTPtr As SAFEARRAY1D
With SApWAVE_OBJECT
.cDims = 1
.fFeatures = 0
.cbElements = 1
.cLocks = 0
.pvData = 0
.Bounds(0).lLbound = 0
.Bounds(0).cElements = 1
End With
With SApWAVE_OBJECTPtr
.cDims = 1
.fFeatures = 0
.cbElements = 4
.cLocks = 0
.pvData = VarPtr(SApWAVE_OBJECT.pvData)
.Bounds(0).lLbound = 0
.Bounds(0).cElements = 1
End With
CopyMemory ByVal VarPtrArray(pWAVE_OBJECT), VarPtr(SApWAVE_OBJECT), 4
CopyMemory ByVal VarPtrArray(pWAVE_OBJECTPtr), VarPtr(SApWAVE_OBJECTPtr), 4
lpWaveObj = idEvent
pWAVE_OBJECTPtr(0) = lpWaveObj
'Debug.Print "WaveTimerProc " & pWAVE_OBJECT(0).dwFlag

Call WaveSpread(pWAVE_OBJECT(0))
Call WaveRender(pWAVE_OBJECT(0))
With pWAVE_OBJECT(0)
If (.dwFlag And F_WO_NEED_UPDATE) Then
hdc = GetDC(.hWnd)
Call WaveUpdateFrame(pWAVE_OBJECT(0), hdc, False)
Call ReleaseDC(.hWnd, hdc)
End If
'********************************************************************
' 特效处理
'********************************************************************
If (.dwFlag And F_WO_EFFECT) = 0 Then Exit Sub
Select Case .dwEffectType
'********************************************************************
' Type = 1 雨点，Param1＝速度（0最快，越大越慢），Param2＝雨点大小，Param3＝能量
'********************************************************************
Case 1
'Dim ret As Long
If .dwEffectParam1 > 0 Then Call WaveRandom(pWAVE_OBJECT(0), .dwEffectParam1) 'ret = WaveRandom(pWAVE_OBJECT(0), .dwEffectParam1)
'If ret = 0 Then
dwPosX = WaveRandom(pWAVE_OBJECT(0), .dwBmpWidth - 2) + 1
dwPosY = WaveRandom(pWAVE_OBJECT(0), .dwBmpHeight - 2) + 1
dwSize = WaveRandom(pWAVE_OBJECT(0), .dwEffectParam2) + 1
dwWeight = WaveRandom(pWAVE_OBJECT(0), .dwEffectParam3) + 50
Call WaveDropStone(pWAVE_OBJECT(0), dwPosX, dwPosY, dwSize, dwWeight)
'End If
'********************************************************************
' Type = 2 行船，Param1＝速度（0最快，越大越快），Param2＝大小，Param3＝能量
'********************************************************************
Case 2
.dwEff2Flip = .dwEff2Flip + 1
If (.dwEff2Flip And 1) <> 0 Then Exit Sub
dwPosX = .dwEff2X + .dwEff2XAdd
dwPosY = .dwEff2Y + .dwEff2YAdd
If dwPosX < 1 Then
dwPosX = -(dwPosX - 1)
.dwEff2XAdd = -.dwEff2XAdd
End If
If dwPosY < 1 Then
dwPosY = -(dwPosY - 1)
.dwEff2YAdd = -.dwEff2YAdd
End If
If dwPosX > .dwBmpWidth - 1 Then
dwPosX = (.dwBmpWidth - 1) - (dwPosX - (.dwBmpWidth - 1)) '(.dwBmpWidth - 1)*2 -dwPosX
.dwEff2XAdd = -.dwEff2XAdd
End If
If dwPosY > .dwBmpHeight - 1 Then
dwPosY = (.dwBmpHeight - 1) - (dwPosY - (.dwBmpHeight - 1)) '(.dwBmpHeight-1)*2-dwPosY
.dwEff2YAdd = -.dwEff2YAdd
End If
.dwEff2X = dwPosX
.dwEff2Y = dwPosY
Call WaveDropStone(pWAVE_OBJECT(0), dwPosX, dwPosY, .dwEffectParam2, .dwEffectParam3)
'********************************************************************
' Type = 3 波浪，Param1＝密度，Param2＝大小，Param3＝能量
'********************************************************************
Case 3
Dim I As Long
For I = 0 To .dwEffectParam1
dwPosX = WaveRandom(pWAVE_OBJECT(0), .dwBmpWidth - 2) + 1
dwPosY = WaveRandom(pWAVE_OBJECT(0), .dwBmpHeight - 2) + 1
dwSize = WaveRandom(pWAVE_OBJECT(0), .dwEffectParam2) + 1
dwWeight = WaveRandom(pWAVE_OBJECT(0), .dwEffectParam3)
Call WaveDropStone(pWAVE_OBJECT(0), dwPosX, dwPosY, dwSize, dwWeight)
Next
End Select
End With
'取消模拟指针
CopyMemory ByVal VarPtrArray(pWAVE_OBJECT), 0&, 4
CopyMemory ByVal VarPtrArray(pWAVE_OBJECTPtr), 0&, 4
End Sub

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'释放对象
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Sub WaveFree(lpWaveObject As WAVE_OBJECT)
With lpWaveObject
If .hDcRender > 0 Then DeleteDC (.hDcRender)
If .hBmpRender > 0 Then DeleteObject .hBmpRender
If .lpDIBitsSource > 0 Then GlobalFree .lpDIBitsSource
If .lpDIBitsRender > 0 Then GlobalFree .lpDIBitsRender
If .lpWave1 > 0 Then GlobalFree .lpWave1
If .lpWave2 > 0 Then GlobalFree .lpWave2
KillTimer .hWnd, VarPtr(lpWaveObject)
ZeroMemory ByVal VarPtr(lpWaveObject), Len(lpWaveObject)
'-----------------------------------------------------------
'取消模拟指针
CopyMemory ByVal VarPtrArray(pLong), 0&, 4
CopyMemory ByVal VarPtrArray(pLongPtr), 0&, 4
'-----------------------------------------------------------------
'取消模拟指针
CopyMemory ByVal VarPtrArray(pByte), 0&, 4
CopyMemory ByVal VarPtrArray(pBytePtr), 0&, 4
'-----------------------------------------------------------
End With
End Sub

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 初始化对象
' 参数：_lpWaveObject ＝ 指向 WAVE_OBJECT结构体
' 返回：0 成功、 1 失败
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Function WaveInit(lpWaveObject As WAVE_OBJECT, ByVal hWnd As Long, ByVal hBmp As Long, ByVal dwSpeed As Long, ByVal dwType As WaveType) As Long
Dim stBmp As BITMAP
Dim dwReturn As Long
Dim ret As Long
Dim hdc As Long
Dim hMDC As Long
'-----------------------------------------------------------------
'建立模拟指针
With SApLong
.cDims = 1
.fFeatures = 0
.cbElements = 1
.cLocks = 0
.pvData = 0
.Bounds(0).lLbound = 0
.Bounds(0).cElements = 1
End With
With SApLongPtr
.cDims = 1
.fFeatures = 0
.cbElements = 4
.cLocks = 0
.pvData = VarPtr(SApLong.pvData)
.Bounds(0).lLbound = 0
.Bounds(0).cElements = 1
End With
CopyMemory ByVal VarPtrArray(pLong), VarPtr(SApLong), 4
CopyMemory ByVal VarPtrArray(pLongPtr), VarPtr(SApLongPtr), 4
'-----------------------------------------------------------------
'建立模拟指针
With SApByte
.cDims = 1
.fFeatures = 0
.cbElements = 1
.cLocks = 0
.pvData = 0
.Bounds(0).lLbound = 0
.Bounds(0).cElements = 3
End With
With SApBytePtr
.cDims = 1
.fFeatures = 0
.cbElements = 4
.cLocks = 0
.pvData = VarPtr(SApByte.pvData)
.Bounds(0).lLbound = 0
.Bounds(0).cElements = 1
End With
CopyMemory ByVal VarPtrArray(pByte), VarPtr(SApByte), 4
CopyMemory ByVal VarPtrArray(pBytePtr), VarPtr(SApBytePtr), 4
'-----------------------------------------------------------------
dwReturn = 0
ZeroMemory ByVal VarPtr(lpWaveObject), Len(lpWaveObject)
'ZeroMemory lpWaveObject, &H84 ' Len(WAVE_OBJECT)

With lpWaveObject

If dwType = sEllipse Then
.dwFlag = .dwFlag Or F_WO_ELLIPSE
End If
'********************************************************************
' 获取位图尺寸
'********************************************************************
.hWnd = hWnd
.dwRandom = GetTickCount()

ret = GetObject(hBmp, Len(stBmp), stBmp)
If ret = 0 Then
dwReturn = 1
GoTo result
End If

.dwBmpHeight = stBmp.bmHeight
'if lpWaveObject.dwBmpHeight < 3 then dwReturn = 1:GoTo result
.dwBmpWidth = stBmp.bmWidth
'if lpWaveObject.dwBmpWidth < 3 then dwReturn = 1:GoTo result
.dwWaveByteWidth = stBmp.bmWidth * &H4 '2 ^ 2 'dwBmpWidth * 4
.dwDIByteWidth = (stBmp.bmWidth + stBmp.bmWidth * 2 + 3) And (Not &H3&) '(dwBmpWidth * 3 + 3) and ~3 ' ((W * 3& + 3&) And (Not 3&))
'********************************************************************
' 创建用于渲染的位图
'********************************************************************
hdc = GetDC(hWnd)
.hDcRender = CreateCompatibleDC(hdc)
.hBmpRender = CreateCompatibleBitmap(hdc, .dwBmpWidth, .dwBmpHeight)
'MsgBox .hBmpRender
SelectObject .hDcRender, .hBmpRender
'********************************************************************
' 分配波能缓冲区
'********************************************************************
.lpWave1 = GlobalAlloc(GPTR, .dwWaveByteWidth * .dwBmpHeight)
.lpWave2 = GlobalAlloc(GPTR, .dwWaveByteWidth * .dwBmpHeight)
'********************************************************************
' 分配像素缓冲区
'********************************************************************
.lpDIBitsSource = GlobalAlloc(GPTR, .dwDIByteWidth * .dwBmpHeight)
.lpDIBitsRender = GlobalAlloc(GPTR, .dwDIByteWidth * .dwBmpHeight)
'********************************************************************
' 获取原始像素数据
'********************************************************************
'With .stBmpInfo.bmiHeader
.stBmpInfo.bmiHeader.biSize = Len(.stBmpInfo.bmiHeader) ' &H28 'len(BITMAPINFOHEADER)
.stBmpInfo.bmiHeader.biWidth = .dwBmpWidth
.stBmpInfo.bmiHeader.biHeight = -.dwBmpHeight '- .dwBmpHeight
.stBmpInfo.bmiHeader.biPlanes = 1
.stBmpInfo.bmiHeader.biBitCount = 24
.stBmpInfo.bmiHeader.biCompression = BI_RGB
.stBmpInfo.bmiHeader.biSizeImage = 0
'End With

hMDC = CreateCompatibleDC(hdc)
SelectObject hMDC, hBmp
ReleaseDC hWnd, hdc

GetDIBits hMDC, hBmp, 0, .dwBmpHeight, .lpDIBitsSource, .stBmpInfo, DIB_RGB_COLORS
GetDIBits hMDC, hBmp, 0, .dwBmpHeight, .lpDIBitsRender, .stBmpInfo, DIB_RGB_COLORS
DeleteDC hMDC

If .lpWave1 = 0 Or .lpWave2 = 0 Or .lpDIBitsSource = 0 Or .lpDIBitsRender = 0 Or .hDcRender = 0 Then
WaveFree lpWaveObject
dwReturn = 1
End If

'Debug.Print "WaveInit " & .dwFlag
SetTimer hWnd, ByVal VarPtr(lpWaveObject), dwSpeed, AddressOf WaveTimerProc
.dwFlag = .dwFlag Or F_WO_ACTIVE Or F_WO_NEED_UPDATE
'Debug.Print "WaveInit " & .dwFlag
WaveRender lpWaveObject
hdc = GetDC(.hWnd)
WaveUpdateFrame lpWaveObject, hdc, True
ReleaseDC .hWnd, hdc
End With

'********************************************************************
result:
WaveInit = dwReturn
End Function

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 一些特效
' 输入：dwType = 0 关闭特效
' dwType <> 0 开启特效，参数具体见上面
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Sub WaveEffect(lpWaveObject As WAVE_OBJECT, ByVal dwEffectType As WaveEffectType, ByVal dwParam1 As Long, ByVal dwParam2 As Long, ByVal dwParam3 As Long)
Dim dwMaxX As Long, dwMaxY As Long
With lpWaveObject
' Debug.Print "WaveEffect " & .dwFlag
Select Case dwEffectType
Case wClose '关闭特效
.dwFlag = .dwFlag And (Not F_WO_EFFECT)
.dwEffectType = dwEffectType
Exit Sub
'Case wrain '下雨
Case wLaunch '汽艇
.dwEff2XAdd = dwParam1
.dwEff2YAdd = dwParam1
.dwEff2X = WaveRandom(lpWaveObject, .dwBmpWidth - 2) + 1
.dwEff2Y = WaveRandom(lpWaveObject, .dwBmpHeight - 2) + 1
' .dwEffectType = dwEffectType
' .dwEffectParam1 = dwParam1
' .dwEffectParam2 = dwParam2
' .dwEffectParam3 = dwParam3
' .dwFlag = .dwFlag Or F_WO_EFFECT
'Case wWaves '风浪
'Case Else '默认
End Select
.dwEffectType = dwEffectType
.dwEffectParam1 = dwParam1
.dwEffectParam2 = dwParam2
.dwEffectParam3 = dwParam3
.dwFlag = .dwFlag Or F_WO_EFFECT
End With
End Sub

完

'3个模块.模块123。一个资源文件。资源文件中放置一个位图标识号1
'*****模块1
Option Explicit

' Window Functions
Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)

' Message
Public Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Public Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long

Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Public Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long)

Public Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Public Declare Function LoadBitmapBynum Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As Long) As Long
'Public Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As String) As Long
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long

Public Const LR_LOADFROMFILE = &H10
Public Const IMAGE_BITMAP = 0

' Class Reg And Del
Public Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
Public Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer

'Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Public Declare Function BeginPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Public Declare Function EndPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (ByVal dest As Long, ByVal numbytes As Long)

Public Const HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2

Public Const MB_OK = &H0&
Public Const MB_ICONHAND = &H10&
Public Const MB_ICONSTOP = MB_ICONHAND

Public Const WM_PAINT = &HF
Public Const WM_CLOSE = &H10
Public Const WM_CREATE = &H1
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_DESTROY = &H2

Public Const WS_SYSMENU = &H80000
Public Const WS_OVERLAPPED = &H0&

' WNDCLASSEX
Public Const CS_HREDRAW = &H2
Public Const CS_VREDRAW = &H1

' Window Color
Public Const COLOR_WINDOW = 5

' ShowWindow
Public Const SW_SHOWNORMAL = 1

' DefSystem Cursor
Public Const IDC_ARROW = 32512&

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Type PAINTSTRUCT
hdc As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(32) As Byte
End Type

Public Type POINTAPI
x As Long
y As Long
End Type

' Reg Window
Public Type WNDCLASSEX
cbSize As Long
Style As Long
lpfnWndProc As Long
cbClsExtra As Long
cbWndExtra As Long
hInstance As Long
hIcon As Long
hCursor As Long
hbrBackground As Long
lpszMenuName As String
lpszClassName As String
hIconSm As Long
End Type

Public Type MSG
hWnd As Long
message As Long
wParam As Long
lParam As Long
Times As Long
pt As POINTAPI
End Type

Public Function FnPtrToLong(ByVal lngFnPtr As Long) As Long
FnPtrToLong = lngFnPtr
End Function

'*****模块2
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 水波特效演示程序 VB版本
' by 书林跋涉 改写编译自罗云彬：实现水波特效的代码例子，参考了不少网上代码
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 所有实现特效的代码单独封装在 WaveObject.bas 中
' 具体使用方法见 WaveObject.bas 中的说明
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

Option Explicit
Private hInstance As Long
Private hWinMain As Long

Private Const szClassName = "Ripper"
Private Const szTitle = "水波效果 - http://asm.yeah.net"
Private Const szTip = "水波特效演示 by 书林跋涉" & vbCrLf _
& "使用VB6语言编写，原WIN32汇编源代码见http://asm.yeah.net" & vbCrLf & vbCrLf _
& "鼠标左键：在点击处激发水波" & vbCrLf _
& "鼠标右键：循环切换特效（下雨、快艇、波浪等）"
Private Const szError = "初始化水波对象错误!"

Private stWaveObj As WAVE_OBJECT

Private Sub Quit()
WaveFree stWaveObj
DestroyWindow hWinMain
Call PostQuitMessage(0)
End Sub

Private Sub Init()
Dim hBmp As Long
Dim hWidth As Long
Dim hHeight As Long
'Dim wsRound As WaveType
'Dim weRain As WaveEffectType
Dim ret As Long
'在vb IDE运行，用这句
hBmp = LoadImage(hInstance, App.Path & "\Ripper.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
'生成exe运行，用下面这句代替
'hBmp = LoadBitmapBynum(hInstance, 1)
'wsRound = sRound
With stWaveObj
.dwFlag = 0
.hWnd = hWinMain
End With
' Debug.Print "Init()"
' ret = WaveInit(stWaveObj, hWinMain, hBmp, 30, sEllipse)
ret = WaveInit(stWaveObj, hWinMain, hBmp, 30, sRound)
If ret = 1 Then
MessageBox hWinMain, szError, szTitle, MB_OK Or MB_ICONSTOP
Call Quit
Else
MessageBox hWinMain, szTip, szTitle, MB_OK
End If
DeleteObject hBmp
'********************************************************************
' 将窗口大小修正到位图的大小
'********************************************************************
hWidth = stWaveObj.dwBmpWidth + 6
hHeight = stWaveObj.dwBmpHeight + 25
SetWindowPos hWinMain, HWND_TOPMOST, 0, 0, hWidth, hHeight, SWP_NOMOVE
'weRain = wRain
WaveEffect stWaveObj, wRain, 5, 4, 250
'weRain = wLaunch
'WaveEffect stWaveObj, weRain, 4, 2, 180
End Sub

Private Function ProcWinMain(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim stPS As PAINTSTRUCT
Dim hdc As Long
'Dim stRect As RECT
Dim stPos As POINTAPI
'Dim WaveET As WaveEffectType
Select Case uMsg
Case WM_CREATE
hWinMain = hWnd
Call Init
Case WM_CLOSE
Call Quit
Case WM_PAINT
hdc = BeginPaint(hWnd, stPS)
WaveUpdateFrame stWaveObj, hdc, True
EndPaint hWnd, stPS
ProcWinMain = 0
Exit Function
'********************************************************************
'鼠标左键激起水波
'********************************************************************
Case WM_LBUTTONDOWN
'GetCursorPos stPos
stPos.x = lParam And &HFFFF&
stPos.y = (lParam And &HFFFF0000) \ &H10000 '2 ^ 16
WaveDropStone stWaveObj, stPos.x, stPos.y, 2, 256
Case WM_RBUTTONDOWN
Select Case stWaveObj.dwEffectType
Case 0
'WaveET = wRain
WaveEffect stWaveObj, wRain, 5, 4, 250
Case 1
'WaveET = wWaves
WaveEffect stWaveObj, wWaves, 250, 4, 8
Case 3
'WaveET = wLaunch
WaveEffect stWaveObj, wLaunch, 4, 2, 180
Case Else
'WaveET = wClose
WaveEffect stWaveObj, wClose, 0, 0, 0
End Select
Case WM_DESTROY
Call PostQuitMessage(0)
'Case Else
'ProcWinMain = DefWindowProc(hWnd, uMsg, wParam, lParam)
'Exit Function
End Select
ProcWinMain = DefWindowProc(hWnd, uMsg, wParam, lParam)
'ProcWinMain = 0
End Function
Private Sub WinMain()
Dim stWndClass As WNDCLASSEX
Dim stMsg As MSG
'********************************************************************
' 注册窗口类
'********************************************************************
hInstance = App.hInstance
ZeroMemory ByVal VarPtr(stWndClass), Len(stWndClass)
With stWndClass
.hCursor = LoadCursor(ByVal 0&, IDC_ARROW)
.hInstance = hInstance
.cbSize = Len(stWndClass)
.Style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = FnPtrToLong(AddressOf ProcWinMain)
.hbrBackground = COLOR_WINDOW + 1
.lpszClassName = szClassName
'.hIcon = LoadIconBynum(.hInstance, ICO_MAIN) ' LoadResPicture(ICO_MAIN, vbResIcon) '
End With
Call RegisterClassEx(stWndClass)
'********************************************************************
' 建立并显示窗口
'********************************************************************
hWinMain = CreateWindowEx(0, szClassName, szTitle, WS_OVERLAPPED Or WS_SYSMENU, 300, 300, 500, 500, 0, 0, hInstance, ByVal 0&)
If hWinMain <> 0 Then
ShowWindow hWinMain, SW_SHOWNORMAL
UpdateWindow hWinMain
Do While GetMessage(stMsg, 0, 0, 0)
TranslateMessage stMsg
DispatchMessage stMsg
Loop
End If
UnregisterClass szClassName, hInstance
End Sub

Private Sub Main()
Call WinMain
'ExitProcess 0&
End Sub

'*********模块3在这里

'*****模块3****

'*************************************************************************
'**模 块 名：WaveObject
'**说 明：水波效果公用子程序
'**创 建 人：书林跋涉
'**描 述：WaveObject VB版本由书林跋涉改写编译自罗云彬：实现水波特效的代码例子，参考了不少网上代码如孤帆的WaveObj.dll
'**版 本：V1.0.0
'*************************************************************************
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByVal lpBits As Long, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
'将来自与设备无关位图的二进制位复制到一幅与设备有关的位图里
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByVal lpBits As Long, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
'将一幅与设备无关位图的全部或部分数据直接复制到一个设备
'Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, ByVal lpvBits As Long, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'-------------------------------------------------------
'模拟指针
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Var() As Any) As Long

Private Type SAFEARRAYBOUND
cElements As Long '这一维有多少个元素？
lLbound As Long '它的索引从几开始？
End Type

Private Type SAFEARRAY1D
cDims As Integer '这个数组有几维？
fFeatures As Integer '这个数组有什么特性？
cbElements As Long '数组的每个元素有多大？
cLocks As Long '这个数组被锁定过几次？
pvData As Long '这个数组里的数据放在什么地方？
Bounds(0 To 0) As SAFEARRAYBOUND
End Type
'-----------------------------------------------------

'-----------------------------------------------------------------
'模拟指针
Private pLong() As Long
Private pLongPtr() As Long
Private SApLong As SAFEARRAY1D
Private SApLongPtr As SAFEARRAY1D
Private pByte() As Byte
Private pBytePtr() As Long
Private SApByte As SAFEARRAY1D
Private SApBytePtr As SAFEARRAY1D
'-----------------------------------------------------------------

Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

Public Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

Public Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Public Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type

Public Enum F_WO_FLAG
F_WO_ACTIVE = &H1&
F_WO_NEED_UPDATE = &H2&
F_WO_EFFECT = &H4&
F_WO_ELLIPSE = &H8&
End Enum

Public Type WAVE_OBJECT
hWnd As Long
dwFlag As F_WO_FLAG ' 见 F_WO_xxx 组合
'********************************************************************
hDcRender As Long
hBmpRender As Long
lpDIBitsSource As Long '原始像素数据
lpDIBitsRender As Long '用于显示到屏幕的像素数据
lpWave1 As Long '水波能量数据缓冲1
lpWave2 As Long '水波能量数据缓冲2
'********************************************************************
dwBmpWidth As Long '
dwBmpHeight As Long '
dwDIByteWidth As Long ' = (dwBmpWidth * 3 + 3) and ~3
dwWaveByteWidth As Long ' = dwBmpWidth * 4
dwRandom As Long '
'********************************************************************
' 特效参数
'********************************************************************
dwEffectType As Long '
dwEffectParam1 As Long '
dwEffectParam2 As Long '
dwEffectParam3 As Long '
'********************************************************************
' 用于行船特效
'********************************************************************
dwEff2X As Long '
dwEff2Y As Long '
dwEff2XAdd As Long '
dwEff2YAdd As Long '
dwEff2Flip As Long '
'********************************************************************
stBmpInfo As BITMAPINFO
End Type

Public Enum WaveType
sRound = 0 '圆形水波
sEllipse = 1 '椭圆型水波
End Enum

Public Enum WaveEffectType
wClose = 0 '关闭特效
wRain = 1 '下雨
wLaunch = 2 '汽艇
wWaves = 3 '风浪
End Enum

'********************************************************************
'1、创建水波对象：
'要对一个窗口进行绘画，首先要创建一个水波对象（本函数申请一些缓冲区）
'Function WaveInit(lpWaveObject As WAVE_OBJECT,ByVal hwnd&, ByVal hBmp&, ByVal dwSpeed&, ByVal dwType As WaveType) As Long
' lpWaveObject --> 指向一个空的 WAVE_OBJECT 结构 '(的指针)
' hWnd --> 要绘画水波效果的窗口，渲染后的图片将画到窗口的客户区中
' hBmp --> 背景图片，绘画的范围大小同背景图片大小
' dwTime --> 刷新的时间间隔（毫秒），建议值：10～30
' dwType --> =0 表示圆形水波，=1表示椭圆型水波（用于透视效果）
' 返回值： 0（成功，对象被初始化），1（失败）
'********************************************************************
'2、如果 _WaveInit 函数返回成功，则对象被初始化，将对象传给下列各种函数
' 可以实现各种效果，下面函数中的 lpWaveObject 参数指向在 _WaveInit 函数
' 中初始化的 WAVE_OBJECT 结构;
' ◎ 在指定位置“扔石头”，激起水波
'Sub WaveDropStone(lpWaveObject As WAVE_OBJECT, ByVal dwPosX As Long, ByVal dwPosY As Long, ByVal dwStoneSize As Long, ByVal dwStoneWeight As Long)
' dwPosX,dwPosY --> 扔下石头的位置
' dwStoneSize --> 石头的大小，即初始点的大小，建议值：0～5
' dwStoneWeight --> 石头的重量，决定了波最后扩散的范围大小，建议值：10～1000
'
' ◎ 自动显示特效
'Sub WaveEffect(ByVal dwEffectType As WaveEffectType, ByVal dwParam1&, ByVal dwParam2&, ByVal dwParam3&)
' dwParam1,dwParam2,dwParam3 --> 效果参数，对不同的特效类型参数含义不同
' dwEffectType --> 特效类型
' 0 --> 关闭特效
' 1 --> 下雨，Param1＝密集速度（0最密，越大越稀疏），建议值：0～30
' Param2＝最大雨点直径，建议值：0～5
' Param3＝最大雨点重量，建议值：50～250
' 2 --> 汽艇，Param1＝速度（0最慢，越大越快），建议值：0～8
' Param2＝船大小，建议值：0～4
' Param3＝水波扩散的范围，建议值：100～500
' 3 --> 风浪，Param1＝密度（越大越密），建议值：50～300
' Param2＝大小，建议值：2～5
' Param3＝能量，建议值：5～10

' ◎ 窗口客户区强制更新（用于在窗口的WM_PAINT消息中强制更新客户端）
' Case WM_PAINT
' hdc = BeginPaint(hWnd, stPS)
' WaveUpdateFrame stWaveObj, hdc, True
' EndPaint hWnd, stPS
' ProcWinMain = 0
' Exit Function
'
'********************************************************************
' 3、释放水波对象：
' 使用完毕后，必须将水波对象释放（本函数将释放申请的缓冲区内存等资源）
'Sub WaveFree(lpWaveObject As WAVE_OBJECT)
' lpWaveObject --> 指向 WAVE_OBJECT 结构
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 实现上的细节说明：
'
' 1、 水波的特征：
' ◎ 扩散：每一点的波会扩散到其四周的位置中
' ◎ 衰减：每次扩散会损失少量能量（否则水波会永不停止的震荡下去）
'
' 2、 为了保存两个时刻中的能量分步图，对象中定义2个缓冲区Wave1和Wave2
' （保存在lpWave1和lpWave2指向的缓冲区内），Wave1为当前数据，Wave2为
' 上一帧的数据，每次渲染时将根据上面的2个特征，由Wave1的数据计算出新
' 能量分别图后，保存到Wave2中，然后调换Wave1和Wave2，这时Wave1仍是最
' 新的数据。
' 计算的方法为，某个点的能量＝点四周的上次能量的平均值 * 衰减系数
' 取四周的平均值表现了扩展特征，乘以衰减系数表现了衰减特征。
' 这部分代码在 WaveSpread 子程序中实现。
'
' 3、 对象在 lpDIBitsSource 中保存了原始位图的数据，每次渲染时，由原始
' 位图的数据根据Wave1中保存的能量分步数据产生新的位图。从视觉上看，
' 某个点的能量越大（水波越大），则光线折射出越远处的场景。
' 算法为：对于点（x,y），在Wave1中找出该点，计算出相邻点的波能差
' （Dx和Dy两个数据），则新位图像素（x,y）＝原始位图像素（x+Dx,y+Dy），
' 该算法表现了能量大小影响了像素折射的偏移大小。
' 这部分代码在 WaveRender 子程序中实现。
'
' 4、 扔石头的算法很好理解，即将Wave1中的某个点的能量值置为非0值，数值
' 越大，表示扔下的石头的能量越大。石头比较大，则将该点四周的点全部
' 置为非0值。
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 随机数产生子程序
' 输入：要产生的随机数的最大值，输出：随机数
' 根据：
' 1. 数学公式 Rnd=(Rnd*I+J) mod K 循环回带生成 K 次以内不重复的
' 伪随机数，但K,I,J必须为素数
' 2. 2^(2n-1)-1 必定为素数（即2的奇数次方减1）
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Function WaveRandom16(lpWaveObject As WAVE_OBJECT) As Long
Dim lRnd As Long
'为防止溢出，做了修改
With lpWaveObject
lRnd = ((.dwRandom And &HFFFF&) * &H7FF& + &H7F&) Mod &H7FFF
WaveRandom16 = .dwRandom And &HFF&
.dwRandom = lRnd
End With
'WaveRandom16 = lpWaveObject.dwRandom
'lpWaveObject.dwRandom = (lpWaveObject.dwRandom * &H7FFF& + &H7FF&) Mod &H7FFFFFFF
'WaveRandom16 = WaveRandom16 And &HFFFF&
End Function
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Function WaveRandom(lpWaveObject As WAVE_OBJECT, ByVal dwMax As Long) As Long
Dim lRnd1 As Long, lRnd2 As Long
lRnd1 = WaveRandom16(lpWaveObject)
lRnd2 = WaveRandom16(lpWaveObject) 'And &H7FFF&
lRnd2 = lRnd2 * &H100 '2 ^ 8 '左移8位
WaveRandom = lRnd2 + lRnd1
If dwMax = 0 Then Exit Function
WaveRandom = WaveRandom Mod dwMax '整除，返回不大于dwMax的整数。
End Function

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' 波能扩散
' 算法：
'椭圆扩散
' Wave2(x,y) = ((Wave1(x+1,y)+Wave1(x-1,y)+Wave1(x+2,y)+Wave1(x-2,y))*3+Wave1(x+3,y)*2+Wave1(x-3,y)*2+ Wave1(x,y+1)*8+Wave1(x,y-1)*8)/16-Wave2(x,y)
'十字扩散
' Wave2(x,y) = (Wave1(x+1,y)+Wave1(x-1,y)+Wave1(x,y+1)+Wave1(x,y-1))/2-Wave2(x,y)
' Wave2(x,y) = Wave2(x,y) - Wave2(x,y) >> 5
' 交换 Wave1,Wave2
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Sub WaveSpread(lpWaveObject As WAVE_OBJECT)
Dim lpWave1 As Long, lpWave2 As Long ', dwBmpWidth As Long, dwBmpHeight As Long
Dim lData As Long
Dim LineIdx As Long
Dim LinePtr1 As Long, LinePtr2 As Long ', CurPtr As Long
Dim I As Long

With lpWaveObject
'Debug.Print "WaveSpread " & .dwFlag
If (.dwFlag And F_WO_ACTIVE) = 0 Then Exit Sub
lpWave1 = .lpWave1
lpWave2 = .lpWave2
'dwBmpWidth = .dwBmpWidth
'dwBmpHeight = .dwBmpHeight - 1
LineIdx = (.dwBmpHeight - 1) * .dwBmpWidth 'DIB是逆序存储的
For I = .dwBmpWidth To LineIdx - 1
LinePtr1 = lpWave1 + I * 4
LinePtr2 = lpWave2 + I * 4
If (.dwFlag And F_WO_ELLIPSE) <> 0 Then '椭圆扩散
'CurPtr = LinePtr - 1 * 4
pLongPtr(0) = LinePtr1 - 1 * 4 ' CurPtr
lData = pLong(0) '每个元素4个字节
pLongPtr(0) = LinePtr1 + 1 * 4
lData = lData + pLong(0)
pLongPtr(0) = LinePtr1 - 2 * 4
lData = lData + pLong(0)
pLongPtr(0) = LinePtr1 + 2 * 4
lData = lData + pLong(0)
lData = lData + lData * 2 'lData=lData*3
pLongPtr(0) = LinePtr1 - 3 * 4
lData = lData + pLong(0) + pLong(0) 'lData = lData + pLong(0) * 2
pLongPtr(0) = LinePtr1 + 3 * 4
lData = lData + pLong(0) + pLong(0) 'lData = lData + pLong(0) * 2

pLongPtr(0) = LinePtr1 - .dwWaveByteWidth
lData = lData + pLong(0) * &H8 '2 ^ 3
pLongPtr(0) = LinePtr1 + .dwWaveByteWidth
lData = lData + pLong(0) * &H8 '2 ^ 3

lData = lData \ &H10 '2 ^ 4
pLongPtr(0) = LinePtr2
lData = lData - pLong(0)

If lData < 0 Then lData = 0

lData = lData - lData \ &H20 ' 2 ^ 5

pLongPtr(0) = LinePtr2
pLong(0) = lData
Else '十字扩散
pLongPtr(0) = LinePtr1 - 1 * 4
lData = pLong(0)
pLongPtr(0) = LinePtr1 + 1 * 4
lData = lData + pLong(0)

pLongPtr(0) = LinePtr1 - .dwWaveByteWidth
lData = lData + pLong(0)
pLongPtr(0) = LinePtr1 + .dwWaveByteWidth
lData = lData + pLong(0)

lData = lData \ &H2 ' 2 ^ 1
pLongPtr(0) = LinePtr2
lData = lData - pLong(0)

If lData < 0 Then lData = 0

lData = lData - lData \ &H20 '2 ^ 5
'If lData <> 0 Then Debug.Print lData
pLongPtr(0) = LinePtr2
pLong(0) = lData
End If
Next 'I
.lpWave1 = lpWave2
.lpWave2 = lpWave1
'Debug.Print "WaveSpread " & .dwFlag
End With
End Sub
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' esi -> edi, ecx = line width
' return = (4*Pixel(x,y)+3*Pixel(x-1,y)+3*Pixel(x+1,y)+3*Pixel(x,y+1)+3*Pixel(x,y-1))/16
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Sub WaveGetPixel(lpDIBitsSource As Long, lpDIBitsRender As Long, ByVal dwDIByteWidth As Long)
Dim LinePtr As Long
Dim iTmpSrcB As Integer, iTmpSrcG As Integer, iTmpSrcR As Integer
Dim iSrcB As Integer, iSrcG As Integer, iSrcR As Integer
Dim bDestB As Byte, bDestG As Byte, bDestR As Byte

LinePtr = lpDIBitsSource
pBytePtr(0) = LinePtr
iTmpSrcR = pByte(2) 'Red
iTmpSrcG = pByte(1) 'Green
iTmpSrcB = pByte(0) 'Blue
iSrcR = iTmpSrcR * &H4 '2 ^ 2
iSrcG = iTmpSrcG * &H4 '2 ^ 2
iSrcB = iTmpSrcB * &H4 '2 ^ 2
pBytePtr(0) = LinePtr + 3 '24位
iTmpSrcR = pByte(2) 'Red
iTmpSrcG = pByte(1) 'Green
iTmpSrcB = pByte(0) 'Blue
iSrcR = iSrcR + (iTmpSrcR + iTmpSrcR * 2) ' iSrcR = iSrcR + iTmpSrcR * 3
iSrcG = iSrcG + (iTmpSrcG + iTmpSrcG * 2)
iSrcB = iSrcB + (iTmpSrcB + iTmpSrcB * 2)
pBytePtr(0) = LinePtr - 3 '24位
iTmpSrcR = pByte(2) 'Red
iTmpSrcG = pByte(1) 'Green
iTmpSrcB = pByte(0) 'Blue
iSrcR = iSrcR + (iTmpSrcR + iTmpSrcR * 2) ' iSrcR = iSrcR + iTmpSrcR * 3
iSrcG = iSrcG + (iTmpSrcG + iTmpSrcG * 2)
iSrcB = iSrcB + (iTmpSrcB + iTmpSrcB * 2)
pBytePtr(0) = LinePtr + dwDIByteWidth
iTmpSrcR = pByte(2) 'Red
iTmpSrcG = pByte(1) 'Green
iTmpSrcB = pByte(0) 'Blue
iSrcR = iSrcR + (iTmpSrcR + iTmpSrcR * 2) ' iSrcR = iSrcR + iTmpSrcR * 3
iSrcG = iSrcG + (iTmpSrcG + iTmpSrcG * 2)
iSrcB = iSrcB + (iTmpSrcB + iTmpSrcB * 2)
pBytePtr(0) = LinePtr - dwDIByteWidth
iTmpSrcR = pByte(2) 'Red
iTmpSrcG = pByte(1) 'Green
iTmpSrcB = pByte(0) 'Blue
iSrcR = iSrcR + (iTmpSrcR + iTmpSrcR * 2) ' iSrcR = iSrcR + iTmpSrcR * 3
iSrcG = iSrcG + (iTmpSrcG + iTmpSrcG * 2)
iSrcB = iSrcB + (iTmpSrcB + iTmpSrcB * 2)

iSrcR = iSrcR \ &H10 And &HFF 'iSrcR / 2 ^ 4 And &HFF
iSrcG = iSrcG \ &H10 And &HFF 'iSrcG / 2 ^ 4 And &HFF
iSrcB = iSrcB \ &H10 And &HFF 'iSrcB / 2 ^ 4 And &HFF
bDestR = iSrcR
bDestG = iSrcG
bDestB = iSrcB

LinePtr = lpDIBitsRender
pBytePtr(0) = LinePtr
pByte(2) = bDestR 'Red
pByte(1) = bDestG 'Green
pByte(0) = bDestB 'Blue

lpDIBitsSource = lpDIBitsSource + 3
lpDIBitsRender = lpDIBitsRender + 3
End Sub

未完。

我收集了几个能实现的代码

已上传至 http://vbfan.ys168.com 

下载所需密码已经发给你短消息了，望查收

我在 www.52shop.hk买的水本，质量还不错哦！

---

晋州市19242113284： VB如何实现水波纹?？
堂胡雌莫： Private Declare Function WaterInit Lib ＂waterdll.dll＂ (ByVal bitmap As Long) As Long Private Declare Function WaterMouseAction Lib ＂waterdll.dll＂ (ByVal hdc As _ Long, ByVal sx As Long, ByVal sy As Long, ByVal mx As Long, _ ByVal my ...

晋州市19242113284： VB:编写一个实现如下功能的通用过程 - ？
堂胡雌莫： Private Sub Command1_Click() Call InputInfo(＂猪头纹＂, 5) End Sub Public Sub InputInfo(UserName As String, outRow As Integer) Dim strWelcome As String strWelcome = ＂欢迎＂ & UserName & ＂同志参加VB.NET讨论会!＂ Do While (outRow > 0) Print strWelcome outRow = outRow - 1 Loop End Sub

晋州市19242113284： 求一段简单的VB代码,高手来! - ？
堂胡雌莫： 简单方法:Private Sub Form_Load() If App.PrevInstance = True Then MsgBox ＂已经启动了这个程序,不能重复启动＂ End End If Form1.Show End Sub

晋州市19242113284： VB一个简单问题 - ？
堂胡雌莫： 实现下面的代码是Private Sub Command1_Click()Form1.BackColor = &HFFFF00End Sub背景显示蓝色!还可以这样Private Sub Command1_Click()Form1.BackColor = vbblueEnd Sub

晋州市19242113284： 求一段VB代码:要求Label1从窗体右下角滚到左上角,完成后,标准继续从右下角滚到左上角,依次循环 - ？
堂胡雌莫： private void button1_Click(object sender, EventArgs e) { timer1.Enabled = true; } private void Form1_Load(object sender, EventArgs e) { label1.Left = this.Width; label1.Top = this.Height; } private void timer1_Tick(object sender, EventArgs e) { if (...

晋州市19242113284： VB编程.题目如下.谁有灵感的高手.给我提示下用什么控件,怎样思路什么的.介绍一下. - ？
堂胡雌莫： 我基本看明白你的问题了.你看这样行不行,首先建立一个VB程序,然后再建立一个txt文本文件,暂命名为1.1.txt里面有很多消息...

晋州市19242113284： 在vb中如何设计一个电子滚动屏幕,使 欢迎使用 几个汉字在窗体中自左向右反复滚 - ？
堂胡雌莫： 在窗体中建一个标签,Caption= “欢迎使用!＂ 再在窗体中加入一Timer控件.Private Sub Form_Load() Form1.Timer1.Interval = 100 End Sub Private Sub Timer1_Timer() If Form1.Label1.Left > Form1.Width Then Form1.Label1.Left = 0 Else Form1.Label1.Left = Form1.Label1.Left + 100 End If End Sub

晋州市19242113284： 我想在VB中实现这样一个功能？
堂胡雌莫： 建议用MsflexGrid,可以不做数据控件绑定. 1、将数据写进去表格控件用类似Cell(i.j)=N语句即可. 2、 全部入库功能可以用循环.读MsflexGrid一行数据,Insert语句插入数据一次.

晋州市19242113284： 编写一个VB程序,把某个图形装入一个图片框中,且能实现该图形的放大,缩小和全屏显示 - ？
堂胡雌莫： image 控件,属性设置图片大小适应控件,放大缩小只要改变image控件的height, left, top 属性就可以.

晋州市19242113284： VB的编程 实现以下功能:(1)密码一“*”的形式显示,用户名和密码最大长度为6个字符 - ？
堂胡雌莫： Dim M_Times As IntegerPrivate Sub Command1_Click() If Text1.Text = ＂ABC＂ And Text2.Text = ＂123＂ T...