Option Explicit
Private 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
Private Declare Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, 
ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc 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 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 Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount 
As Long, lpBits As Any) 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As 
Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private MyHdc1 As Long, MyBmp1 As Long, MyOldBmp1 As Long, ScrW As Long, ScrH As Long
Private StartT As Single
Private 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 = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
  'Ws2.Close
  SelectObject MyHdc1, MyOldBmp1
  DeleteObject MyBmp1
  DeleteDC MyHdc1
End Sub
Private 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 Sub
Private Sub Ws2_Close()
  StatusBar1.SimpleText = Ws2.RemoteHost & " Disconnected.."
  Ws2.Close
End Sub
Private Sub Ws2_Connect()
  StatusBar1.SimpleText = Ws2.RemoteHost & " Connected.."
End Sub
Private 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.Close
End Sub


'=============================================================
'項目名稱:   Server (遠程屏幕監控端)
'窗口名稱：   FrmServer
'WinSock控件：Ws1
'StatusBar控件:StatusBar1 (注意：StatusBar1.Style = sbrSimple)
'=============================================================


Option Explicit
Private 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
Private Declare Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, 
ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc 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 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 Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount 
As Long, lpBits As Any) 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As 
Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private ScrW As Long, ScrH As Long
Private MyHdc As Long, MyBmp As Long, MyOldBmp As Long, BmpDat() As Byte, RevByte As Long
Private StartT As Single
Private 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 Error
End Sub
Sub getscreen()
End Sub
Private Sub Form_Unload(Cancel As Integer)
  On Error Resume Next
  WS1.Close
  SelectObject MyHdc, MyOldBmp
  DeleteObject MyBmp
  DeleteDC MyHdc
End Sub
Private Sub WS1_Close()
  StatusBar1.SimpleText = WS1.RemoteHostIP & " Disconnected.."
  WS1.Close
  If WS1.State = sckListening Then
    WS1.Close
  Else
    WS1.LocalPort = 2345
    WS1.Listen
  End If
End Sub
Private 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 Sub
Private 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 Sub
Private 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