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
你是直接在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