求一个能实现屏幕水波纹效果的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买的水本,质量还不错哦!
刚买的笔记本只要我用手晃动了电脑,电脑显示屏的两个地方同时间也会
水波大表示屏幕质量较差,水波小表示屏幕质量较好,所有液晶屏都会有水波一般不是特别用力的晃动是不会有水波的,但是挤压都会出现水波,如果只是轻微的晃动就出现水波那这个液晶面板就有问题了。LCD 面板水波纹产生的几个因素 1.电源干扰;开关电源没有 50HZ干扰,可减少水波纹。2.地线没分好;模拟和数字...
我的电脑偶尔有屏幕上一道像水波一样的闪动这是怎么会事啊
不是啊,我们老师前几天说了这个问题 这是因为驱动程序须要更新一下了 还有你说的是屏幕上有似水波的杂纹啊,那就应该是显卡须要驱动一下
拉动滚动条时候,屏幕像水波一样晃动
这个显卡驱动问题!现在只有,NV和ATI两种显卡,你去下一个万能显卡驱动试试,NV和ATI两种显卡驱动都安装上,如果不行,那应该是集成显卡,集成显卡,一般都是INTEL,你自己看看是什么型号,在网上搜一下,应该能找到吧!
液晶显示器出现轻微水波正常吗?
有点漏光,很正常
LED显示屏有波纹怎么回事?
用数码相机拍摄景物中,如果有密纹的纹理,常常会出现莫名其妙的水波样条纹。这就是摩尔纹。简单的说,摩尔纹是差拍原理的一种表现。从数学上讲, 两个频率接近的等幅正弦波叠加,合成信号的幅度将按照两个频率之差变化。第三、LED电子显示屏摩尔纹产生的过程 1、两个空间频率略有差异的条纹,它们左端...
示波器看不出来水波
2、检查输入耦合是不是DC档(如果只关注信号的交流成分,AC耦合也可以),GND耦合的话,不管输入什么信号,波形都是水平线。 3、再看下触发源是不是选中了输入通道,如果选中了没有信号接入的CH2做触发源,CH1的信号是不会得到触发的。 4、试着将垂直刻度调小。一个幅度为5mV的信号,用5V\/div...
浏览网页的时候屏幕滚动的像水波一样,有什么办法解决
是所有的网页都这样?那么病毒引起的可能就很小了 建议 1.就如楼上讲的,为显示器消一下磁。再看看情况 2.这种情况也有可能是外部电压不足造成的。有可能的话,换一个电源或单独为显示配一个稳压电源试试。
...会出现水波一样的东西,就像用手按在电脑显示器一样,是坏了吗_百度...
不是坏了的问题,是这块屏幕属于合格产品,不属于优等品,建议你拿到手机店要求换机。
...会出现水波一样的东西,就像用手按在电脑显示器一样,是坏了吗_百度...
让我来告诉你答案!这个不是手机坏了。是手机的硬件问题。我曾经刚买了一个三星I569就有你说的这个情况,不影响正常使用,但是看着心里特别不舒服。最后我拿到客服去,人家给换了一台。但是新机还是有这个情况,最后一问才知道原来我的这个机型全部有这毛病,属于硬件的问题,你在换都解决不了。除非你...
求助,拍照对焦后屏幕老出现水波一样的波纹
若手机屏幕出现波纹,建议您:1.部分机型支持解锁时滑动屏幕出现"涟漪效果",操作方法:打开设定-锁定屏幕-锁屏选项(滑动选项)-(解锁效果)-涟漪效果-勾选/取消(在锁屏上显示涟漪效果,如果锁屏上已设置动态壁纸,涟漪效果将自动禁用)。2.若非滑动解锁时出现波纹,建议您携带购机发票、包修卡和机器送...
堂胡雌莫: 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...