[转贴]一个比较那个的代码！

      发到这儿来主要是原先的发布格式太乱，看起来不方便
      来源那个网页上也没有，作者看到本页面，可以和我联系，我加上你的大名。
      对了，代码是AxWebBrowser应用的完整例子，用于自动提交网页表单

Option   Explicit   On  
Imports  mshtml
Imports  System.DateTime
Imports  Microsoft.VisualBasic
Public   Class form1 Class form1
Inherits System.Windows.Forms.Form
Windows 窗体设计器生成的代码#Region " Windows 窗体设计器生成的代码 "
Public Sub New()Sub New()
MyBase.New()

'该调用是 Windows 窗体设计器所必需的。
InitializeComponent()
'在 InitializeComponent() 调用之后添加任何初始化
'brow.Navigate("http://www.netsh.com")
'brow.Navigate("h:\softuyou.htm")
'brow.Navigate("http://goal28.ziqu.com/bbs/250006/")
'brow.Navigate("http://www.netsh.net/subdomains/f_s_o.php?p=0&leibie=wenxue")
'brow.Navigate("http://my.clubhi.com/bbs/661134/")

Randomize()
End Sub
'窗体重写 dispose 以清理组件列表。
Protected Overloads Overrides Sub Dispose()Sub Dispose(ByVal disposing As Boolean)
If disposing Then
If Not (components Is Nothing) Then
components.Dispose()
End If
End If
MyBase.Dispose(disposing)
End Sub
'Windows 窗体设计器所必需的
Private components As System.ComponentModel.IContainer
'注意: 以下过程是 Windows 窗体设计器所必需的
'可以使用 Windows 窗体设计器修改此过程。
'不要使用代码编辑器修改它。
Friend WithEvents txtAddress As System.Windows.Forms.TextBox
Friend WithEvents brow As AxSHDocVw.AxWebBrowser
Friend WithEvents lblStatus As System.Windows.Forms.Label
Friend WithEvents MainMenu1 As System.Windows.Forms.MainMenu
Friend WithEvents MenuItem1 As System.Windows.Forms.MenuItem
Friend WithEvents mnuFill As System.Windows.Forms.MenuItem
Friend WithEvents mnuNetsh As System.Windows.Forms.MenuItem
Friend WithEvents lst1Url As System.Windows.Forms.ListBox
Friend WithEvents mnuTest As System.Windows.Forms.MenuItem
<System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()Sub InitializeComponent()
Dim resources As System.Resources.ResourceManager = New System.Resources.ResourceManager(GetType(form1))
Me.txtAddress = New System.Windows.Forms.TextBox
Me.lblStatus = New System.Windows.Forms.Label
Me.brow = New AxSHDocVw.AxWebBrowser
Me.MainMenu1 = New System.Windows.Forms.MainMenu
Me.MenuItem1 = New System.Windows.Forms.MenuItem
Me.mnuFill = New System.Windows.Forms.MenuItem
Me.mnuNetsh = New System.Windows.Forms.MenuItem
Me.mnuTest = New System.Windows.Forms.MenuItem
Me.lst1Url = New System.Windows.Forms.ListBox
CType(Me.brow, System.ComponentModel.ISupportInitialize).BeginInit()
Me.SuspendLayout()
'
'txtAddress
'
Me.txtAddress.Location = New System.Drawing.Point(176, 8)
Me.txtAddress.Name = "txtAddress"
Me.txtAddress.Size = New System.Drawing.Size(568, 21)
Me.txtAddress.TabIndex = 0
Me.txtAddress.Text = ""
'
'lblStatus
'
Me.lblStatus.Location = New System.Drawing.Point(8, 8)
Me.lblStatus.Name = "lblStatus"
Me.lblStatus.Size = New System.Drawing.Size(160, 16)
Me.lblStatus.TabIndex = 1
Me.lblStatus.Text = "Status"
'
'brow
'
Me.brow.Enabled = True
Me.brow.Location = New System.Drawing.Point(8, 32)
Me.brow.OcxState = CType(resources.GetObject("brow.OcxState"), System.Windows.Forms.AxHost.State)
Me.brow.Size = New System.Drawing.Size(344, 520)
Me.brow.TabIndex = 2
'
'MainMenu1
'
Me.MainMenu1.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {Me.MenuItem1, Me.mnuFill, Me.mnuNetsh, Me.mnuTest})
'
'MenuItem1
'
Me.MenuItem1.Index = 0
Me.MenuItem1.Text = "&File"
'
'mnuFill
'
Me.mnuFill.Index = 1
Me.mnuFill.Text = "Fi&ll"
'
'mnuNetsh
'
Me.mnuNetsh.Index = 2
Me.mnuNetsh.Text = "&Netsh"
'
'mnuTest
'
Me.mnuTest.Index = 3
Me.mnuTest.Text = "&Test"
'
'lst1Url
'
Me.lst1Url.ItemHeight = 12
Me.lst1Url.Location = New System.Drawing.Point(352, 32)
Me.lst1Url.MultiColumn = True
Me.lst1Url.Name = "lst1Url"
Me.lst1Url.Size = New System.Drawing.Size(432, 520)
Me.lst1Url.Sorted = True
Me.lst1Url.TabIndex = 3
'
'form1
'
Me.AutoScaleBaseSize = New System.Drawing.Size(6, 14)
Me.AutoScroll = True
Me.ClientSize = New System.Drawing.Size(792, 557)
Me.Controls.Add(Me.lst1Url)
Me.Controls.Add(Me.brow)
Me.Controls.Add(Me.lblStatus)
Me.Controls.Add(Me.txtAddress)
Me.Menu = Me.MainMenu1
Me.Name = "form1"
Me.Text = "浏览器（tuenhai)"
Me.WindowState = System.Windows.Forms.FormWindowState.Maximized
CType(Me.brow, System.ComponentModel.ISupportInitialize).EndInit()
Me.ResumeLayout(False)
End Sub
#End Region

netsh 注册和发言整体程序#Region "netsh 注册和发言整体程序"
Private Sub mnuNetsh_Click()Sub mnuNetsh_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mnuNetsh.Click
On Error Resume Next
brow.Navigate("http://www.netsh.com/") '打开首页
Do While brow.Busy
Application.DoEvents()
Loop
SearchKey = "leibie=" '重定义关键词为类别（leibie=)
Call getUrls() '搜集分类网址到列表框
Delay(FromOADate(delayT * 3)) '延时1秒
'MsgBox(lst1Url.Items.Count, MsgBoxStyle.DefaultButton3, "lst1ur1的论坛数")
'Threading.Thread.CurrentThread.Sleep(1000)
Dim countLstNetsh As Short
Dim LstNetsh As New ListBox '新建一ListBox
LstNetsh.Items.AddRange(lst1Url.Items) '复制list1到lstNetsh
lst1Url.Items.Clear()
For countLstNetsh = 0 To LstNetsh.Items.Count - 1
If brow.LocationURL <> LstNetsh.Items(countLstNetsh) Then
brow.Navigate(LstNetsh.Items(countLstNetsh)) '导航到lstNetsh中的第一个地址
End If
'Delay(FromOADate(delayT / 5)) '延时1秒
Do While brow.Busy
Application.DoEvents()
Loop
'Threading.Thread.CurrentThread.Sleep(1000)
'Delay(FromOADate(delayT * 3))
'MsgBox(brow.LocationURL)
'**********************以下得到编程栏的网址类别目录列表***************
Dim instrLeibie As Short
Dim LocUrl As String = LstNetsh.Items(countLstNetsh)
instrLeibie = InStr(LocUrl, SearchKey, CompareMethod.Text)
SearchKey = Strings.Right(LocUrl, Len(LstNetsh.Items(countLstNetsh)) - instrLeibie + 1) '得到搜索关键词leibie=biancheng
MsgBox(SearchKey, MsgBoxStyle.DefaultButton1, "newsearchkey")
lst1Url.Items.Clear() '先清空列表框
Call getUrls() '搜索包含leibie=biancheng的网址
Delay(FromOADate(delayT * 3)) '延时1秒
'Threading.Thread.CurrentThread.Sleep(1000)
lst1Url.Items.Add(brow.LocationURL) '再加上当前网址
Dim LstBianCheng As New ListBox '编程目录
LstBianCheng.Items.AddRange(lst1Url.Items) '把lst1Url中的网址传到LstBiancheng
lst1Url.Items.Clear() '清空lst1Url
'**************************导航到biacheng目录中的第1页,并得到论坛网址目录
Dim countLstBianCheng As Short
For countLstBianCheng = 0 To LstBianCheng.Items.Count - 1 '编程目录的页数
If brow.LocationURL <> LstBianCheng.Items(countLstBianCheng) Then
brow.Navigate(LstBianCheng.Items(countLstBianCheng)) '导航到编程目录的第一页
End If
' Delay(FromOADate(delayT / 5)) '延时1秒
Do While brow.Busy
Application.DoEvents()
Loop
'Threading.Thread.CurrentThread.Sleep(1000)
'Delay(FromOADate(delayT * 3))
Call GetForms()
Delay(FromOADate(delayT * 3)) '延时1秒
'Threading.Thread.CurrentThread.Sleep(1000)
Dim LstBianChengUrl As New ListBox '编程目录第1页的论坛列表
LstBianChengUrl.Items.AddRange(lst1Url.Items)
lst1Url.Items.Clear()
Dim countLstBianchUrl As Short
For countLstBianchUrl = 0 To LstBianChengUrl.Items.Count - 1
brow.Navigate(LstBianChengUrl.Items(countLstBianchUrl))
'Delay(FromOADate(delayT / 5)) '延时1秒
'Threading.Thread.CurrentThread.Sleep(1000)
Do While brow.Busy
Application.DoEvents()
Loop
Delay(FromOADate(delayT * 3))
'MsgBox(brow.Document.all.tags("html").item(0).outerhtml, MsgBoxStyle.DefaultButton3, _
' "看看打开的论坛源代码中有没有FRAMESET,有就执行下面代码")

If InStr(brow.Document.all.tags("html").item(0).outerhtml, "FRAMESET") Then
If InStr(brow.Document.frames(0).document.body.innerhtml, "发表新帖子") Then '如果网页中有"发表新帖子"就执行
Dim bcUrl As String = LstBianChengUrl.Items(countLstBianchUrl)
MsgBox(bcUrl, MsgBoxStyle.DefaultButton3, "LstBianChengUrl.Items(countLstBianchUrl)")
Dim bookNum As String = Strings.Right(bcUrl, Len(bcUrl) - InStrRev(bcUrl, "/", -1, CompareMethod.Text))
MsgBox(bookNum)
Dim UrlAdd As String = Strings.Left(bcUrl, InStr(8, bcUrl, "/", CompareMethod.Text)) & "fcgi-bin/addboard.fcgi?bookname=" & bookNum
brow.Navigate(UrlAdd)
'Delay(FromOADate(delayT / 5))
Do While brow.Busy
Application.DoEvents()
Loop
'Threading.Thread.CurrentThread.Sleep(1000)
'Delay(FromOADate(delayT * 3))
'MsgBox(UrlAdd, MsgBoxStyle.DefaultButton3, "urladd")
'MsgBox(brow.Document.body.innertext, MsgBoxStyle.DefaultButton2, "body中有没有第一次发言请注册")
If InStr(brow.Document.body.innertext, "第一次发言请注册") Then '如果要求注册
Dim urlSign As String = Strings.Left(bcUrl, InStr(8, bcUrl, "/", CompareMethod.Text)) & "cgi-bin/signup.cgi?bookname=" & bookNum
brow.Navigate(urlSign)
'Delay(FromOADate(delayT / 5))
'MsgBox(urlSign, MsgBoxStyle.DefaultButton1, "urlsign")
Do While brow.Busy
Application.DoEvents()
Loop
'Threading.Thread.CurrentThread.Sleep(1000)
'Delay(FromOADate(delayT * 3))
Call mnufill_Click(sender, e) '呼叫注册程序
Delay(FromOADate(delayT * 3))
Do While brow.Busy
Application.DoEvents()
Loop
'Threading.Thread.CurrentThread.Sleep(1000)
brow.Navigate(UrlAdd)
Do While brow.Busy
Application.DoEvents()
Loop
'Threading.Thread.CurrentThread.Sleep(1000)
'Delay(FromOADate(delayT * 3))
Call mnufill_Click(sender, e) '发表新帖子
Delay(FromOADate(delayT * 3))
Do While brow.Busy
Application.DoEvents()
Loop
'Threading.Thread.CurrentThread.Sleep(1000)
Else
Call mnufill_Click(sender, e)
Do While brow.Busy
Application.DoEvents()
Loop
'Threading.Thread.CurrentThread.Sleep(1000)
'Delay(FromOADate(delayT * 3))
End If
End If
End If
Next countLstBianchUrl
Exit For
Next countLstBianCheng
Exit For
Next countLstNetsh
End Sub
#End Region
netsh注册和发言#Region "netsh注册和发言"
Private Sub mnufill_Click()Sub mnufill_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mnuFill.Click
On Error Resume Next
Do While brow.Busy
Application.DoEvents()
Loop
Dim cardNum As Integer = Int((9999 * Rnd()) + 1000)
Dim countTag As Short
Dim webDoc As Object = brow.Document.all
Dim webTag As Object
Dim lengthTag As Short = webDoc.length - 1
lst1Url.Items.Clear()
For countTag = 0 To lengthTag
If InStr(brow.LocationURL, "signup.cgi?bookname") Then '如果网址中包含signup，就执行下面代码
If UCase(webDoc.item(countTag).tagname) = "IMG" Then '如果找到img标签，就写值
webDoc.Item(countTag).src = "http://www.netsh.net/subdomains/put_img.php?str=492972"
End If
End If
If LCase(webDoc.item(countTag).tagname) = "input" Or LCase(webDoc.item(countTag).tagname) = "textarea" Then '找到input或textarea标签
webTag = webDoc.item(countTag)
If Not webDoc("str") Is Nothing Then
webDoc("str").value = strStr '重写name为str的网页元素值
End If
If LCase(webTag.type) = "text" Or LCase(webTag.type) = "password" Then '找到text或password标签
Select Case webTag.name
Case "name", "userid" '用户名
webTag.value = strName
Case "passwd", "password", "confirm" '密码，确认密码
webTag.value = strPass '
Case "subject" '标题
webTag.value = strSubject & cardNum
Case "regid" '注册码
webTag.value = strRegid
Case "username"
webTag.value = GetRndChar(6, 2) '真实姓名
Case "cardnumber"
webTag.value = strCardNumber & cardNum '证件号
Case "homephone"
webTag.value = strHomephone '电话号
End Select
ElseIf webTag.name = "body" Then
webTag.value = strBody
End If
End If
Next
brow.Document.forms(0).submit()

End Sub
#End Region

以SearchKey为关键词得到网址#Region "以SearchKey为关键词得到网址"
Private Sub getUrls()Sub getUrls()
On Error Resume Next
Do While brow.Busy
Application.DoEvents()
Loop
Dim countTag As Short
Dim webDoc As Object = brow.Document.all
Dim webTag As Object
Dim lengthTag As Short = webDoc.length - 1
For countTag = 0 To lengthTag
If LCase(webDoc.item(countTag).tagname) = "a" Then
webTag = webDoc.item(countTag).href
If InStr(webTag, SearchKey) Then
lst1Url.Items.Add(webTag)
End If
End If
Next countTag '以上代码得到网址列表
Dim CountLst1 As Short '以下代码去除重复地址
Dim Lst2Url() As String
Dim UBoundLst2 As Short
With lst1Url
ReDim Preserve Lst2Url(0)
Lst2Url(0) = .Items(0) '新数组的第一项和list的第一项相同
For CountLst1 = 1 To .Items.Count - 1 'items.count得到list1中的项目数
UBoundLst2 = UBound(Lst2Url) 'curid为newlist中有项目数
If .Items(CountLst1) <> Lst2Url(UBoundLst2) Then '如果旧表第二项不等于新表第一项
ReDim Preserve Lst2Url(UBoundLst2 + 1) '定位到新表第二项
Lst2Url(UBoundLst2 + 1) = .Items(CountLst1) '新表第二项等于旧表第二项
End If
Next CountLst1
.Items.Clear() '删除旧表所有项
For CountLst1 = 0 To UBound(Lst2Url) '把新表写入旧表
.Items.Add(Lst2Url(CountLst1))
Next CountLst1
End With
End Sub
#End Region
得到netsh网页中的论坛网址,并加入到lst1Url#Region "得到netsh网页中的论坛网址,并加入到lst1Url"
Private Sub GetForms()Sub GetForms()
On Error Resume Next
Do While brow.Busy
Application.DoEvents()
Loop
Dim countTag As Short
Dim webDoc As Object = brow.Document.all
Dim webTag As Object
Dim lengthTag As Short = webDoc.length - 1
lst1Url.Items.Clear()
For countTag = 0 To lengthTag
If LCase(webDoc.item(countTag).tagname) = "a" Then '得到网址
webTag = webDoc.item(countTag).href
If InStr("1234567890", Strings.Right(webTag, 1)) Then '只选取末位是数字的网址
lst1Url.Items.Add(webTag)
End If
End If
Next countTag '以上代码得到网址列表
Dim countForms As Short '以下代码去除重复地址
Dim lstForms() As String
Dim CurId As Short
With lst1Url
ReDim Preserve lstForms(0)
lstForms(0) = .Items(0) '新数组的第一项和list的第一项相同
For countForms = 1 To .Items.Count - 1 'items.count得到list1中的项目数
CurId = UBound(lstForms) 'curid为newlist中有项目数
If .Items(countForms) <> lstForms(CurId) Then '如果旧表第二项不等于新表最大项
ReDim Preserve lstForms(CurId + 1) '定位到新表第二项
lstForms(CurId + 1) = .Items(countForms) '新表第二项等于旧表第二项
End If
Next countForms
.Items.Clear() '删除旧表所有项
For countForms = 0 To UBound(lstForms) '把新表写入旧表
.Items.Add(lstForms(countForms))
Next countForms
End With
End Sub
#End Region
保存相关信息到文本文件#Region "保存相关信息到文本文件"
Private Sub SaveUser()Sub SaveUser()
Dim F As Integer
Dim FileName As String
Dim UserName As String = "testname"
Dim UserPassword As String = "testpass"
Dim strPath As String
strPath = Application.StartupPath
F = FreeFile()
FileName = strPath & "\user.txt"
FileOpen(F, FileName, OpenMode.Append)
PrintLine(F, DateTime.Now & vbCrLf & "netsh" & vbCrLf & "name=" & UserName)
'这里我们按emailclear的格式导出用户信息
FileClose(F)
End Sub
#End Region
Delay函数#Region "Delay函数"
Public Sub Delay()Sub Delay(ByRef HowLong As Date)
Dim temptime As Object
temptime = DateAdd(DateInterval.Second, HowLong.ToOADate, Now)
While temptime > Now
Application.DoEvents()
End While
'System.Threading.Thread.CurrentThread.Sleep(1000)
End Sub
#End Region
浏览器基本功能#Region " 浏览器基本功能"
Private Sub brow_BeforeNavigate2()Sub brow_BeforeNavigate2(ByVal sender As Object, ByVal e As AxSHDocVw.DWebBrowserEvents2_BeforeNavigate2Event) Handles brow.BeforeNavigate2
txtAddress.Text = e.uRL
End Sub
Private Sub txtAddress_KeyPress()Sub txtAddress_KeyPress(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyPressEventArgs) Handles txtAddress.KeyPress
Dim KeyAscii As Short = Asc(e.KeyChar)
If KeyAscii = 13 Then
brow.Navigate((txtAddress.Text))
End If
If KeyAscii = 0 Then
e.Handled = True
End If
End Sub
Private Sub brow_StatusTextChange()Sub brow_StatusTextChange(ByVal sender As Object, ByVal e As AxSHDocVw.DWebBrowserEvents2_StatusTextChangeEvent) Handles brow.StatusTextChange
lblStatus.Text = e.text
End Sub
Private Sub brow_NewWindow2()Sub brow_NewWindow2(ByVal sender As Object, ByVal e As AxSHDocVw.DWebBrowserEvents2_NewWindow2Event) Handles brow.NewWindow2
e.ppDisp = brow.Application
e.cancel = True
End Sub
#End Region
Private Sub mnuTest_Click()Sub mnuTest_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mnuTest.Click
' On Error Resume Next
End Sub
End Class

转载于:https://www.cnblogs.com/dhcn/archive/2006/07/04/442817.html