Option ExplicitPrivate Type BITMAP    bmType As Long    bmWidth As Long   

 bmHeight As Long    bmWidthBytes As Long    bmPlanes As Integer    

bmBitsPixel As Integer    bmBits As LongEnd TypePrivate Declare Function GetObj 

Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, 

lpObject As Any) As LongPrivate Declare Function GetDesktopWindow Lib "user32" ()

 As LongPrivate Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As 

LongPrivate Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal

 hdc As Long) As LongPrivate 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 LongPrivate Declare Sub CopyMemory Lib "Kernel32" Alias 

"RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private

 Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount

 As Long, lpBits As Any) As LongPrivate Declare Function SetBitmapBits Lib

 "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As

 LongPrivate Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As 

Long, ByVal nWidth As Long, ByVal nHeight As Long) As LongPrivate Declare 

Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As LongPrivate 

Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As 

Long) As LongPrivate Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) 

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

As LongPrivate MyHdc1 As Long, MyBmp1 As Long, MyOldBmp1 As Long, ScrW As Long, 

ScrH As LongPrivate StartT As SinglePrivate Sub Form_Load()  Dim bm As BITMAP, 

BmpSize As Long  Timer1.Enabled = False   '间隔时间获取图形  Me.ScaleMode = 3 

 ScrW = Screen.Width \ Screen.TwipsPerPixelX  ScrH = Screen.Height \ Screen.

TwipsPerPixelY  '这只是方便调试的示例，实用程序中，不用临时DC，可直接取窗体的BMP，会快一些 

 MyHdc1 = CreateCompatibleDC(FrmClient.hdc)  MyBmp1 = CreateCompatibleBitmap

(FrmClient.hdc, ScrW, ScrH)  MyOldBmp1 = SelectObject(MyHdc1, MyBmp1) 

 'Ws2为WinSock控件，用于发送数据     'Ws2.RemoteHost = InputBox

("请输入远程ip地址", "远程监控测试", "127.0.0.1")  'Ws2.RemotePort = 2345  

'Ws2.Connect  Timer1.Interval = 10000  Timer1.Enabled = TrueEnd SubPrivate Sub 

Form_Unload(Cancel As Integer)  'Ws2.Close  SelectObject MyHdc1, MyOldBmp1 

 DeleteObject MyBmp1  DeleteDC MyHdc1End SubPrivate Sub Timer1_Timer() 

 Dim i As Long, d As Long, b As Long, bm As BITMAP, dat() As Byte, BmpSize As

 Long  StartT = Timer  d = GetDesktopWindow  i = GetDC(d)  BitBlt MyHdc1, 0, 0, 

ScrW, ScrH, i, 0, 0, vbSrcCopy  ReleaseDC d, i  GetObj MyBmp1, Len(bm), bm  

BmpSize = bm.bmWidthBytes * bm.bmHeight  ReDim dat(BmpSize - 1)  GetBitmapBits 

MyBmp1, BmpSize, dat(0)  ReDim Preserve dat(BmpSize + 1)  dat(BmpSize) = 13 

 dat(BmpSize + 1) = 10  'StartT = Timer  'Ws2.SendData dat  Debug.Print dat  

   'dat为获取到的屏幕图形数据End SubPrivate Sub Ws2_Close()  StatusBar1.

SimpleText = Ws2.RemoteHost & " Disconnected.."  Ws2.CloseEnd SubPrivate Sub 

Ws2_Connect()  StatusBar1.SimpleText = Ws2.RemoteHost & " Connected.."End

 SubPrivate Sub Ws2_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)  On Error Resume Next  

StatusBar1.SimpleText = Ws2.RemoteHost & " Error : " & Description  Ws2.CloseEnd 

Sub'============================================================='项目名称:   

Server (远程屏幕监控端)'窗口名称：   FrmServer'WinSock控件：Ws1'StatusBar控件:

StatusBar1 (注意：StatusBar1.Style = sbrSimple)'=================================

============================Option ExplicitPrivate Type BITMAP    bmType As Long

    bmWidth As Long    bmHeight As Long    bmWidthBytes As Long    bmPlanes As 

Integer    bmBitsPixel As Integer    bmBits As LongEnd TypePrivate Declare 

Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal

 nCount As Long, lpObject As Any) As LongPrivate Declare Function 

GetDesktopWindow Lib "user32" () As LongPrivate Declare Function GetDC Lib 

"user32" (ByVal hwnd As Long) As LongPrivate Declare Function ReleaseDC Lib 

"user32" (ByVal hwnd As Long, ByVal hdc As Long) As LongPrivate 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 LongPrivate Declare Sub

 CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As

 Any, ByVal Length As Long)Private Declare Function GetBitmapBits Lib "gdi32" 

(ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As LongPrivate 

Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount

 As Long, lpBits As Any) As LongPrivate Declare Function CreateCompatibleBitmap

 Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) 

As LongPrivate Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long)

 As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, 

ByVal hObject As Long) As LongPrivate Declare Function DeleteDC Lib "gdi32" 

(ByVal hdc As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal

 hObject As Long) As LongPrivate ScrW As Long, ScrH As LongPrivate MyHdc As Long,

 MyBmp As Long, MyOldBmp As Long, BmpDat() As Byte, RevByte As LongPrivate StartT

 As SinglePrivate Sub Form_Load()  Dim bm As BITMAP, BmpSize As Long    On Error

 GoTo ErrLoad    Me.ScaleMode = 3  ScrW = Screen.Width \ Screen.TwipsPerPixelX  

ScrH = Screen.Height \ Screen.TwipsPerPixelY  '这只是方便调试的示例，实用程序中，

不用临时DC，可直接取窗体的BMP，会快一些  MyHdc = CreateCompatibleDC(FrmServer.hdc)  

MyBmp = CreateCompatibleBitmap(FrmServer.hdc, ScrW, ScrH) 

 MyOldBmp = SelectObject(MyHdc, MyBmp)      GetObj MyBmp, Len(bm),

 bm  BmpSize = bm.bmWidthBytes * bm.bmHeight  ReDim BmpDat(BmpSize - 1) 

 GetBitmapBits MyBmp, BmpSize, BmpDat(0)  WS1.LocalPort = 2345  WS1.Listen   

 Exit Sub  ErrLoad:  MsgBox ErrorEnd SubSub getscreen()End SubPrivate Sub

 Form_Unload(Cancel As Integer)  On Error Resume Next  WS1.Close  SelectObject

 MyHdc, MyOldBmp  DeleteObject MyBmp  DeleteDC MyHdcEnd SubPrivate Sub

 WS1_Close()  StatusBar1.SimpleText = WS1.RemoteHostIP & " Disconnected.." 

 WS1.Close  If WS1.State = sckListening Then    WS1.Close  Else    

WS1.LocalPort = 2345    WS1.Listen  End IfEnd SubPrivate Sub 

Ws1_ConnectionRequest(ByVal requestID As Long)  If WS1.State <> sckClosed Then

 WS1.Close  StatusBar1.SimpleText = WS1.RemoteHostIP & " Connecting.." 

 WS1.Accept requestID  If WS1.State = 7 Then StatusBar1.SimpleText = 

WS1.RemoteHostIP & " Connected.."End SubPrivate Sub Ws1_DataArrival(ByVal

 bytesTotal As Long)  Dim dat() As Byte, i As Long, nTime As Long    

On Error Resume Next    WS1.GetData dat, vbArray Or vbByte  i = InStrB(1, dat,

 ChrB(13) & ChrB(10))  If i > 0 Then    'StartT = Timer    If i > 1 Then

 CopyMemory BmpDat(RevByte), dat(0), i - 1    SetBitmapBits MyBmp, UBound(BmpDat)

 + 1, BmpDat(0)    RevByte = 0    '实用程序中，不用临时DC，下面一步可省   

 BitBlt Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, MyHdc, 0, 0, vbSrcCopy 

   nTime = Timer - Val(Me.Caption)    Me.Caption = Timer - StartT    

If Len(StatusBar1.SimpleText) < 255 Then        StatusBar1.SimpleText =

 nTime & "，" & StatusBar1.SimpleText    Else        StatusBar1.SimpleText = 

nTime    End If    If bytesTotal > i + 1 Then        RevByte = bytesTotal - i - 1 

       CopyMemory BmpDat(0), dat(i + 1), RevByte    End If  Else    CopyMemory 

BmpDat(RevByte), dat(0), bytesTotal    RevByte = RevByte + bytesTotal  End If 

 End SubPrivate Sub WS1_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)  StatusBar1.SimpleText = 

("Error : " & Description)End Sub