程序中加载登录窗口进行登录

VB中加载登录窗口进行登录


你是直接在VB中加载登录窗口进行登录，还是在浏览器中做插件进行登录？


在VB中进行登录：
'函数功能：     登陆网页
'输入参数：     WB:webbrower控件，sURL：网址，OverTime：超时时间，UserName：用户名，UserPWD：用户密码，InPutName：用户名输入框，InPutPWD：密码输入框，LoginFrom：登陆窗体，BtnName：登陆按钮名字
'输出参数：     无
'返回值：       True：成功，false：失败
'******************************************************************
Public Function LoginUrl(WB As WebBrowser, sURL As String, OverTime As Long, UserName As String, UserPWD As String, InputName As String, InputPWD As String, LoginFrom As String, BtnName As String) As Boolean
On Error GoTo errorHandle
    bHtmlFlag = False
    Set sDocument = WB.Document
    sDocument.getElementById(InputName).Value = UserName
    sDocument.getElementById(InputPWD).Value = UserPWD
    If BtnName = "" Then
        sDocument.Forms(LoginFrom).submit
    Else
        sDocument.getElementById(BtnName).Click
    End If
    If HtmlOverTime(OverTime, sURL) = 1 Then        '判断超时
        LoginUrl = False
        InsertLog "登陆网址：" & sURL & "失败！", 1
        Exit Function
    End If
    LoginUrl = True
    Exit Function
errorHandle:
    InsertLog "错误号:" & Err.Number & "错误描述:" & Err.Description, 1
    Debug.Print Err.Description
    Err.Clear
End Function
'******************************************************************
'创建日期：     2008-10-28
'函数功能：     判断网页打开是否超时
'输入参数：     sTime：超时时间
'输出参数：     无
'返回值：       0:成功，1：失败
'******************************************************************
Public Function HtmlOverTime(sTime As Long, sURL As String) As Long
    t = GetTickCount
    Do Until bHtmlFlag = True
        DoEvents
        If GetTickCount - t > sTime Then
            InsertLog "打开网址：" & sURL & "失败！", 1
            HtmlOverTime = 1
            Exit Function
        End If
    Loop
    HtmlOverTime = 0
End Function


如果用插件的 复杂一些，可以查找olelib的知识


'引用olelib实现IObjectWithSite接口来获得IE对象
Implements olelib.IObjectWithSite
'
Private WithEvents m_IEObj As InternetExplorer
Attribute m_IEObj.VB_VarHelpID = -1
Private m_site As olelib.IUnknown
Private sDoc    As New MSHTML.HTMLDocument
 
Private Sub IObjectWithSite_GetSite(riid As olelib.UUID, ppvSite As stdole.IUnknown)
    m_site.QueryInterface riid, ppvSite
End Sub
 
Private Sub IObjectWithSite_SetSite(ByVal pUnkSite As stdole.IUnknown)
     
    Set m_site = pUnkSite
    Set m_IEObj = pUnkSite
End Sub
 
 
'========================================================
'网页加载完成后要处理
'
'
'========================================================
Private Sub m_IEObj_DocumentComplete(ByVal pDisp As Object, URL As Variant)
On Error Resume Next
    Dim strHTML     As String
    Dim strScript       As String
 
    Dim scDoc           As New MSHTML.HTMLDocument
    Dim sHeads          As IHTMLElementCollection
    Dim sHead           As IHTMLHeadElement
    Dim sElement        As IHTMLElement
     
    '获取Script脚本内容
    strScript = getHTMLScript
    'MsgBox URL
     
 
    If InStr(URL, "zs/browseShenbao.do?formId=") > 0 Then
        '获取添加按钮的html语句
        strHTML = GetIni("HTML", "String1", App.Path & "\HtmlMark.ini")
        Set sDoc = m_IEObj.Document
        Set scDoc = sDoc.parentWindow.Document.frames("workspace").Document.frames("top_Frame").Document
        Set scDoc = scDoc.frames("mainFrame").Document
        '获取HEAD头的对象
        Set sHeads = scDoc.getElementsByTagName("HEAD")
        Set sHead = sHeads(0)
        '创建script的节点
        Set sElement = scDoc.createElement("script")
        sElement.setAttribute "language", "JavaScript"
        sElement.setAttribute "text", strScript
        '把script的节点插入到head中
        Call sHead.insertBefore(sElement, Null)
        '把按钮的html语句插入到页面中
        scDoc.body.innerHTML = scDoc.body.innerHTML & strHTML
 
    End If
    '
    If InStr(URL, "/initArchive.do") > 0 Then
        Set sDoc = m_IEObj.Document
        '获取添加按钮的html语句
        strHTML = GetIni("HTML", "String2", App.Path & "\HtmlMark.ini")
 
        Set scDoc = sDoc.parentWindow.Document.frames("workspace").Document.frames("top_Frame").Document
        Set scDoc = scDoc.frames("mainFrame").Document
        '获取HEAD头的对象
        Set sHeads = scDoc.getElementsByTagName("HEAD")
        Set sHead = sHeads(0)
        '创建script的节点
        Set sElement = scDoc.createElement("script")
        sElement.setAttribute "language", "JavaScript"
        sElement.setAttribute "text", strScript
        '把script的节点插入到head中
        Call sHead.insertBefore(sElement, Null)
        '把按钮的html语句插入到页面中
        scDoc.body.innerHTML = scDoc.body.innerHTML & strHTML
 
    End If
    '档案查询页面
    If InStr(URL, "/showDangAn.do?") > 0 Then
        Set sDoc = m_IEObj.Document
        '获取添加按钮的html语句
        strHTML = GetIni("HTML", "String3", App.Path & "\HtmlMark.ini")
        'MsgBox "strHTML---------" & strHTML
        'MsgBox sDoc.body.innerHTML
        Set scDoc = sDoc.parentWindow.Document.frames("workspace").Document.frames("top_Frame").Document
        Set scDoc = scDoc.frames("mainFrame").Document
         
        'MsgBox scDoc.body.innerHTML
        '获取HEAD头的对象
        Set sHeads = scDoc.getElementsByTagName("HEAD")
        Set sHead = sHeads(0)
        '创建script的节点
        Set sElement = scDoc.createElement("script")
        sElement.setAttribute "language", "JavaScript"
        sElement.setAttribute "text", strScript
        '把script的节点插入到head中
        Call sHead.insertBefore(sElement, Null)
        '把按钮的html语句插入到页面中
        scDoc.body.innerHTML = scDoc.body.innerHTML & strHTML
 
    End If
 
End Sub