module1.bas

通过程序向另一软件发送信息或截取另一软件界面上的信息vb源码

Attribute VB_Name = "Module1"
Option Explicit

  Private Type UUID
        Data1   As Long
        Data2   As Integer
        Data3   As Integer
        Data4(0 To 7) As Byte
  End Type
    
  Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    
  Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, lParam As Long) As Long
    
  Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
    
  Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As Any, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
                
  Private Const SMTO_ABORTIFHUNG = &H2
    
  Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, riid As UUID, ByVal wParam As Long, ppvObject As Any) As Long
    
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Public SJuB(500) As Long
  Public K As Integer

  '
  '   IEDOMFromhWnd
  '
  '   Returns   the   IHTMLDocument   interface   from   a   WebBrowser   window
  '
  '   hWnd   -   Window   handle   of   the   control
  '
  Function IEDOMFromhWnd(ByVal hwnd As Long) As IHTMLDocument
        Dim IID_IHTMLDocument As UUID
        Dim hWndChild As Long
        Dim lRes As Long
        Dim lMsg As Long
        Dim hr As Long
    
        If hwnd <> 0 Then
                
              If Not IsIEServerWindow(hwnd) Then
                
                    '   Find   a   child   IE   server   window
                    EnumChildWindows hwnd, AddressOf EnumChildProc, hwnd
                    '  EnumChildWindows hwnd, AddressOf EnumChildProc, ByVal 0&
              End If
                
              If hwnd <> 0 Then
                            
                    '   Register   the   message
                    lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
                            
                    '   Get   the   object   pointer
                    Call SendMessageTimeout(hwnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes)
    
                    If lRes Then
                                  
                          '   Initialize   the   interface   ID
                          With IID_IHTMLDocument
                                .Data1 = &H626FC520
                                .Data2 = &HA41E
                                .Data3 = &H11CF
                                .Data4(0) = &HA7
                                .Data4(1) = &H31
                                .Data4(2) = &H0
                                .Data4(3) = &HA0
                                .Data4(4) = &HC9
                                .Data4(5) = &H8
                                .Data4(6) = &H26
                                .Data4(7) = &H37
                          End With
                                  
                          '   Get   the   object   from   lRes   ObjectFromLresult函数从Internet   Explorer_Server窗口获取IHTMLDocument2接口
                          hr = ObjectFromLresult(lRes, IID_IHTMLDocument, 0, IEDOMFromhWnd)
                                  
                    End If
    
              End If
                
        End If
    
  End Function
    
  Private Function IsIEServerWindow(ByVal hwnd As Long) As Boolean
        Dim lRes As Long
        Dim sClassName As String
    
        '   Initialize   the   buffer
        sClassName = String$(100, 0)
          
        '   Get   the   window   class   name
        lRes = GetClassName(hwnd, sClassName, Len(sClassName))
        sClassName = Left$(sClassName, lRes)
          
        IsIEServerWindow = StrComp(sClassName, "Internet Explorer_Server", vbTextCompare) = 0
          
  End Function
    
  '
  '   Copy   this   function   to   a   .bas   module
  '
  Function EnumChildProc(ByVal hwnd As Long, lParam As Long) As Long
          
        If IsIEServerWindow(hwnd) Then
              lParam = hwnd
        Else
              EnumChildProc = 1
        End If
          
  End Function
  
  
  
  
  
Function GetPassword(ByVal hwnd As Long, ByVal cx As Long, ByVal cy As Long)
        '&apos;我写了这个函数来取得密码,嘿嘿
        Dim Doc As IHTMLDocument
        Dim Ele As IHTMLElement
       
        Set Doc = IEDOMFromhWnd(hwnd)
        Set Ele = Doc.elementFromPoint(cx, cy)
        If Ele.Type = "password " Then
                    GetPassword = Ele.Value
        End If
        Debug.Print "Id   =   " & Ele.id & "   /Title   =   " & Ele.Title & "   /Type   =   " & Ele.Type
End Function
  
  
  
  
  
  
  
    
  '这段代码需要放在模块中才能正常使用,使用时需要引用Microsoft   HTML   Object   Library
  '然后创建一个IHTMLDocument   对象,set   objname   =   IEDOMFromhWnd(hWnd)   就能使用了。
  
'枚举IE的子窗体，得到Internet   Explorer_Server的句柄，调用ObjectFromLresult函数得到Document对象objDocument，就可以操纵叶面上的元素了。比如：
    
     ' For j = 0 To objDocument.All.tags("input").length - 1
     '       Debug.Print CStr(objDocument.All.tags("input")(j).Value)
                          
  'Next j
  'GetDocInterfaceByMSAA
  '然后调用IHTMLDocument2的selection属性。
  '调用selection属性的createRange获取TextRange对象?
  'TextRange对象的text属性就是选中的文本了?
  'IHTMLDocument2-〉IHTMLSeletionObject-〉IHTMLTxtRange
'SMTO_ABORTIFHUNG,   ObjectFromLresult,   IHTMLDocument2,   IHTMLElement