VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)
首页 - 经验之谈 - 建立Web的超链接树形图
发表评论(0)作者:不详, 平台:VB6.0+Win98, 阅读:9652, 日期:2001-06-22
frmHTTPTreeView表单一个,模块HandyStuff,类模块clsHTMLPageResourceNode

Option Explicit

Private Dummy As Variant
Private PageResources As clsHTMLPageResourceNode
Private bPerformingRequest As Boolean
Private BinaryFile As Boolean
Private FilenameForBinaryData As String
Private ActiveTreeNode As Node
Private RootWebNode As clsHTMLPageResourceNode

注释: 目录树中的图标
Private Const icoSERVER = 1
Private Const icoDOCUMENT = 2
Private Const icoTXT = 2
Private Const icoIMAGE = 3
Private Const icoGIF = 3
Private Const icoJPG = 4
Private Const icoBMP = 5
Private Const icoFLASH = 6
Private Const icoRA = 7
Private Const icoWAV = 8
Private Const icoOTHER = 9
Private Const icoCSS = 10
Private Const icoINC = 10
Private Const icoASP = 11
Private Const icoROOT = 14
Private Const icoFloder = 12
Private Const icoFloder1 = 13
Public BrowserFile As String

Private Sub cmdPerformRequest_Click()

注释:清空
  sbHTTPStatus.Panels(1).Text = ""
  sbHTTPStatus.Panels(2).Text = ""

Dim FileExtension As String
Dim TargetFilename As String
Dim TempURL As String
Dim vtBinaryData As Variant
Dim BinaryData() As Byte
Const BinaryFileID = 1

  TempURL = txtURL.Text
If Not URLNormalized(TempURL) Then
    MsgBox "请输入一个有效的IP址或域名", vbCritical, "Invalid URL By Silong,Yu"
    Exit Sub
Else
    txtURL.Text = TempURL
End If

If Not bPerformingRequest Then 注释:确定超链接的类型
    FileExtension = Trim(LCase(ExtractFilenameExtensionFromPath(txtURL.Text)))
Select Case FileExtension
    Case "gif", "jpg"
           BinaryFile = True
           TargetFilename = App.Path & "\" & ExtractFilenameFromPath(txtURL.Text)
           cmnSaveAs.FileName = TargetFilename
           cmnSaveAs.DefaultExt = Right(TargetFilename, 4)
           cmnSaveAs.Filter = "Images(*.bmp;*.gif;*.jpg)"
           cmnSaveAs.CancelError = True
           On Error GoTo Skip
           cmnSaveAs.ShowSave
           bPerformingRequest = True
           cmdPerformRequest.Caption = "停止查询"
           txtURL.Enabled = False
           Me.MousePointer = vbHourglass
           tmrBusy.Enabled = True
           FilenameForBinaryData = cmnSaveAs.FileName

           BinaryData() = Inet1.OpenURL(txtURL.Text, icByteArray)
If bPerformingRequest Then
           Open FilenameForBinaryData For Binary As BinaryFileID
           Put BinaryFileID, , BinaryData()
           Close BinaryFileID
End If

           txtURL.Enabled = True
           tmrBusy.Enabled = False
           Me.MousePointer = vbDefault

           bPerformingRequest = False

           cmdPerformRequest.Enabled = True
           cmdPerformRequest.Caption = "执行查询"
           Skip:
  Case Else
           bPerformingRequest = True
           cmdPerformRequest.Caption = "停止查询"
           tmrBusy.Enabled = True
           Me.MousePointer = vbArrowHourglass
           txtURL.Enabled = False
           BinaryFile = False

           txtOutput.Text = ""
           WritToFile txtOutput    注释:将传送过来的代码,浏览起来
           txtOutput1.Navigate BrowserFile

Set PageResources = New clsHTMLPageResourceNode

txtOutput.Text = ""
WritToFile txtOutput
txtOutput1.Navigate BrowserFile

Inet1.Execute txtURL.Text
End Select
Else
Inet1.Cancel
bPerformingRequest = False
cmdPerformRequest.Caption = "执行查询"
tmrBusy.Enabled = False
Me.MousePointer = vbDefault
txtURL.Enabled = True
Set PageResources = Nothing
End If
End Sub

Private Sub Form_Load()

tvURLTreeView.Width = GetSetting(App.Path, "Option", "Split", 3000)

Me.Width = GetSetting(App.Path, "Option", "Width", Screen.Width / 2)
Me.Height = GetSetting(App.Path, "Option", "Height", Screen.Height / 2)
Me.Left = GetSetting(App.Path, "Option", "Left", (Screen.Width - Me.Width) / 2)
Me.Top = GetSetting(App.Path, "Option", "Top", (Screen.Height - Me.Height) / 2)

Me.WindowState = GetSetting(App.Path, "Option", "Window", 0)

tvURLTreeView.Nodes.Add , , "WWW", "温州东化科技有限公司", _
icoROOT, icoROOT

BrowserFile = App.Path & "\Temp.Htm" 注释:临时文件
WritToFile ""
txtOutput1.Navigate BrowserFile

End Sub

Private Sub Form_Resize()

On Error Resume Next

If Me.WindowState = 1 Then Exit Sub

If Me.ScaleWidth < _
(lblURL.Width + _
cmdPerformRequest.Width + _
200 + 3 * 60) Then
Me.Width = lblURL.Width + _
cmdPerformRequest.Width + _
500 + 4 * 60 + 4
End If
If Me.ScaleHeight < _
(txtOutput1.Top + 500 + 60) Then
Me.Height = txtOutput1.Top + 500 + 60
End If
lblURL.Left = 40
txtURL.Left = lblURL.Left + lblURL.Width + 40
txtURL.Width = Me.ScaleWidth - _
(txtURL.Left + cmdPerformRequest.Width + picBusy.Width + 3 * 80)
cmdPerformRequest.Left = Me.ScaleWidth - _
(cmdPerformRequest.Width + picBusy.Width + 2 * 80)
cmdPerformRequest.Height = txtURL.Height + 20
picBusy.Left = cmdPerformRequest.Left + cmdPerformRequest.Width + 40
tvURLTreeView.Left = 80
tvURLTreeView.Height = Me.ScaleHeight - _
(sbHTTPStatus.Height + tvURLTreeView.Top + 40)
txtOutput1.Top = tvURLTreeView.Top
txtOutput1.Left = tvURLTreeView.Left + tvURLTreeView.Width + 40
txtOutput1.Width = Me.ScaleWidth - (txtOutput1.Left + 40)
txtOutput1.Height = Me.ScaleHeight - _
(sbHTTPStatus.Height + txtOutput1.Top + 40)
picDivider.Top = tvURLTreeView.Top
picDivider.Height = tvURLTreeView.Height
picDivider.Left = tvURLTreeView.Left + tvURLTreeView.Width
picDivider.Width = 40

End Sub


Private Sub Form_Unload(Cancel As Integer)

If Me.WindowState = 0 Then
SaveSetting App.Path, "Option", "Left", Me.Left
SaveSetting App.Path, "Option", "Top", Me.Top
SaveSetting App.Path, "Option", "Width", Me.Width
SaveSetting App.Path, "Option", "Height", Me.Height
SaveSetting App.Path, "Option", "Window", Me.WindowState
End If

End Sub

Private Sub Inet1_StateChanged(ByVal State As Integer)
Dim Loc As Long
Dim sHeaderValue As String
Dim vtDataChunk As Variant
Dim BinaryData() As Byte
Dim Offset As Long
Dim Counter As Long
Dim BinaryFileID As Integer

Select Case State
Case icNone
Case icResolvingHost
sbHTTPStatus.Panels(1).Text = "解析主机"
Case icHostResolved
sbHTTPStatus.Panels(1).Text = "主机解析"
Case icConnecting
sbHTTPStatus.Panels(1).Text = "正在连接..."
Case icConnected
Loc = InStr(Inet1.URL, ":80")
If Loc > 0 Then
txtURL.Text = Left(Inet1.URL, Loc - 1) & Mid(Inet1.URL, Loc + 3)
Else
txtURL.Text = Inet1.URL
End If
Case icRequesting
sbHTTPStatus.Panels(2).Text = "正在查询..."
Case icRequestSent
sbHTTPStatus.Panels(2).Text = "查询发送...."
Case icReceivingResponse
sbHTTPStatus.Panels(2).Text = "接收回答..."
Case icResponseReceived
sbHTTPStatus.Panels(2).Text = "接收回答......"
Case icDisconnecting
sbHTTPStatus.Panels(1).Text = "没有连接"
Case icDisconnected
sbHTTPStatus.Panels(1).Text = "没有连接"
Case icError
sbHTTPStatus.Panels(1).Text = "连接错误"
Case icResponseCompleted
sbHTTPStatus.Panels(2).Text = "查询完成"
sHeaderValue = Inet1.GetHeader("Content-type")
If (Not BinaryFile) And InStr(1, sHeaderValue, "text/", 1) Then
vtDataChunk = Inet1.GetChunk(1024, icString)
Do While Len(vtDataChunk) > 0
注释: 装载文本
txtOutput.Text = txtOutput.Text + vtDataChunk
vtDataChunk = Inet1.GetChunk(1024, icString)
Loop

注释: 写入文件
WritToFile (txtOutput.Text)

txtOutput1.Navigate BrowserFile

sbHTTPStatus.Panels(2).Text = ""
sbHTTPStatus.Panels(1).Text = ""
Else
注释: Alternative way to handle binary files.
sbHTTPStatus.Panels(2).Text = ""
sbHTTPStatus.Panels(1).Text = ""
ReDim BinaryData(0)
vtDataChunk = Inet1.GetChunk(1024, icByteArray)
Do While UBound(vtDataChunk) > 0
If UBound(BinaryData) = 0 Then
Offset = 0
Else
Offset = UBound(BinaryData) + 1
End If
ReDim Preserve BinaryData(LBound(BinaryData) To Offset + UBound(vtDataChunk))
For Counter = 0 To UBound(vtDataChunk)
BinaryData(Counter + Offset) = CByte(vtDataChunk(Counter))
Next Counter
vtDataChunk = Inet1.GetChunk(1024, icByteArray)
Loop
End If
If bPerformingRequest Then
If Not BinaryFile Then
PageResources.URL = txtURL.Text
PageResources.AddLinksFromDocument txtOutput.Text, txtURL
AddLinksToTreeView PageResources
Else
注释: Alternative way to handle binary files.
BinaryFileID = FreeFile
Open FilenameForBinaryData For Binary As BinaryFileID
Put BinaryFileID, , BinaryData()
Close BinaryFileID
End If
txtURL.Enabled = True
tmrBusy.Enabled = False
Me.MousePointer = vbDefault
bPerformingRequest = False
cmdPerformRequest.Enabled = True
cmdPerformRequest.Caption = "执行查询"
End If
Case Else
End Select

End Sub

Private Sub picDivider_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

If Button = vbLeftButton Then
picDivider.Left = _
MaxLong(200, _
MinLong((picDivider.Left + x), _
(Me.ScaleWidth - 260)))
End If

End Sub


Private Sub picDivider_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

tvURLTreeView.Width = picDivider.Left - tvURLTreeView.Left
txtOutput1.Left = picDivider.Left + picDivider.Width
txtOutput1.Width = Me.ScaleWidth - (txtOutput1.Left + 60)

SaveSetting App.Path, "Option", "Split", picDivider.Left

End Sub


Private Sub tmrBusy_Timer()

Static Counter As Integer
Counter = (Counter + 1) Mod (ilBusyIcons.ListImages.Count)
picBusy.Picture = ilBusyIcons.ListImages(Counter + 1).Picture

End Sub

Private Sub tvURLTreeView_NodeClick(ByVal Node As Node)

If (Node.Key <> Node.Root.Key) And _
(Not (Node Is ActiveTreeNode)) And _
(Not bPerformingRequest) Then
Set ActiveTreeNode = Node
txtURL.Text = Node.Key
cmdPerformRequest_Click
End If

End Sub


Private Sub txtURL_GotFocus()

注释: 只选择域名or IPAddress
Dim lLen As Long
lLen = InStr(1, UCase(txtURL), UCase("http://"))
If lLen > 0 Then
txtURL.SelStart = lLen + 6
txtURL.SelLength = Len(txtURL) - lLen - 6
Else
txtURL.SelStart = 0
txtURL.SelLength = Len(txtURL)
End If

End Sub

Private Sub txtURL_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
cmdPerformRequest_Click
End If
End Sub

Public Sub AddLinksToTreeView(PageResources As clsHTMLPageResourceNode)
Dim CurrentNode As Node
Dim Link As clsHTMLPageResourceNode

On Error Resume Next

Set CurrentNode = tvURLTreeView.Nodes.Add("WWW", tvwChild, _
PageResources.URL, _
PageResources.URL, _
icoSERVER, icoSERVER)
If Not (CurrentNode Is Nothing) Then
Set ActiveTreeNode = CurrentNode
End If

For Each Link In PageResources.PageLinks

Dim sExt As String
sExt = Right(Link.Path, 3) 注释:取最后三个
sExt = UCase(sExt)

Select Case sExt

Case "HTM"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoTXT, icoDOCUMENT)
Case "HTML"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoTXT, icoDOCUMENT)
Case "GIF"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoGIF, icoGIF)
Case "JPG"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoJPG, icoJPG)
Case "CSS"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoCSS, icoCSS)
Case "ASP"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoASP, icoASP)
Case "BMP"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoBMP, icoBMP)
Case "MPG"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoRA, icoRA)
Case "AVI"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoRA, icoRA)
Case ".RA"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoRA, icoRA)
Case "INC"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoCSS, icoCSS)
Case "TXT"
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoDOCUMENT, icoDOCUMENT)
Case Else
If InStr(1, sExt, "/") > 1 Then 注释:文件夹
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoFloder, icoFloder1)
Else
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoOTHER, icoOTHER)
End If
End Select

If Not CurrentNode Is Nothing Then
CurrentNode.EnsureVisible
End If
Next Link

For Each Link In PageResources.PageElements
Set CurrentNode = tvURLTreeView.Nodes.Add _
(PageResources.URL, tvwChild, _
Link.URL, Link.Path, _
icoIMAGE, icoIMAGE)
If Not CurrentNode Is Nothing Then
CurrentNode.EnsureVisible
End If
Next Link

End Sub

Public Sub WritToFile(sContent As String)

Dim lFree As Long
lFree = FreeFile
Open BrowserFile For Output As #lFree

Print #lFree, sContent

Close #lFree

End Sub