<p>建立Web的超鏈接樹形圖</p>
<p></p>
<p>frmHTTPTreeView表單一個，模塊HandyStuff，類模塊clsHTMLPageResourceNode </p>
<p></p>
<p>Option Explicit</p>
<p></p>
<p>Private Dummy As Variant</p>
<p>Private PageResources As clsHTMLPageResourceNode</p>
<p>Private bPerformingRequest As Boolean</p>
<p>Private BinaryFile As Boolean</p>
<p>Private FilenameForBinaryData As String</p>
<p>Private ActiveTreeNode As Node</p>
<p>Private RootWebNode As clsHTMLPageResourceNode</p>
<p></p>
<p>注釋： 目錄樹中的圖標</p>
<p>Private Const icoSERVER = 1</p>
<p>Private Const icoDOCUMENT = 2</p>
<p>Private Const icoTXT = 2</p>
<p>Private Const icoIMAGE = 3</p>
<p>Private Const icoGIF = 3</p>
<p>Private Const icoJPG = 4</p>
<p>Private Const icoBMP = 5</p>
<p>Private Const icoFLASH = 6</p>
<p>Private Const icoRA = 7</p>
<p>Private Const icoWAV = 8</p>
<p>Private Const icoOTHER = 9</p>
<p>Private Const icoCSS = 10</p>
<p>Private Const icoINC = 10</p>
<p>Private Const icoASP = 11</p>
<p>Private Const icoROOT = 14</p>
<p>Private Const icoFloder = 12</p>
<p>Private Const icoFloder1 = 13</p>
<p>Public BrowserFile As String</p>
<p></p>
<p>Private Sub cmdPerformRequest_Click()</p>
<p></p>
<p>注釋：清空</p>
<p>  sbHTTPStatus.Panels(1).Text = ""</p>
<p>  sbHTTPStatus.Panels(2).Text = ""</p>
<p></p>
<p>Dim FileExtension As String</p>
<p>Dim TargetFilename As String</p>
<p>Dim TempURL As String</p>
<p>Dim vtBinaryData As Variant</p>
<p>Dim BinaryData() As Byte</p>
<p>Const BinaryFileID = 1</p>
<p></p>
<p>  TempURL = txtURL.Text</p>
<p>If Not URLNormalized(TempURL) Then</p>
<p>    MsgBox "請輸入一個有效的IP址或域名", vbCritical, "Invalid URL By Silong,Yu"</p>
<p>    Exit Sub</p>
<p>Else</p>
<p>    txtURL.Text = TempURL</p>
<p>End If</p>
<p></p>
<p>If Not bPerformingRequest Then 注釋：確定超鏈接的類型</p>
<p>    FileExtension = Trim(LCase(ExtractFilenameExtensionFromPath(txtURL.Text)))</p>
<p>Select Case FileExtension</p>
<p>    Case "gif", "jpg"</p>
<p>           BinaryFile = True</p>
<p>           TargetFilename = App.Path & "\" & ExtractFilenameFromPath(txtURL.Text)</p>
<p>           cmnSaveAs.FileName = TargetFilename</p>
<p>           cmnSaveAs.DefaultExt = Right(TargetFilename, 4)</p>
<p>           cmnSaveAs.Filter = "Images(*.bmp;*.gif;*.jpg)"</p>
<p>           cmnSaveAs.CancelError = True</p>
<p>           On Error GoTo Skip</p>
<p>           cmnSaveAs.ShowSave</p>
<p>           bPerformingRequest = True</p>
<p>           cmdPerformRequest.Caption = "停止查詢"</p>
<p>           txtURL.Enabled = False</p>
<p>           Me.MousePointer = vbHourglass</p>
<p>           tmrBusy.Enabled = True</p>
<p>           FilenameForBinaryData = cmnSaveAs.FileName</p>
<p></p>
<p>           BinaryData() = Inet1.OpenURL(txtURL.Text, icByteArray)</p>
<p>If bPerformingRequest Then</p>
<p>           Open FilenameForBinaryData For Binary As BinaryFileID</p>
<p>           Put BinaryFileID, , BinaryData()</p>
<p>           Close BinaryFileID</p>
<p>End If</p>
<p></p>
<p>           txtURL.Enabled = True</p>
<p>           tmrBusy.Enabled = False</p>
<p>           Me.MousePointer = vbDefault</p>
<p></p>
<p>           bPerformingRequest = False</p>
<p></p>
<p>           cmdPerformRequest.Enabled = True</p>
<p>           cmdPerformRequest.Caption = "執行查詢"</p>
<p>           Skip: </p>
<p>  Case Else</p>
<p>           bPerformingRequest = True</p>
<p>           cmdPerformRequest.Caption = "停止查詢"</p>
<p>           tmrBusy.Enabled = True</p>
<p>           Me.MousePointer = vbArrowHourglass</p>
<p>           txtURL.Enabled = False</p>
<p>           BinaryFile = False</p>
<p></p>
<p>           txtOutput.Text = ""</p>
<p>           WritToFile txtOutput    注釋：將傳送過來的代碼，瀏覽起來</p>
<p>           txtOutput1.Navigate BrowserFile</p>
<p></p>
<p>Set PageResources = New clsHTMLPageResourceNode</p>
<p></p>
<p>txtOutput.Text = ""</p>
<p>WritToFile txtOutput</p>
<p>txtOutput1.Navigate BrowserFile</p>
<p></p>
<p>Inet1.Execute txtURL.Text</p>
<p>End Select</p>
<p>Else</p>
<p>Inet1.Cancel</p>
<p>bPerformingRequest = False</p>
<p>cmdPerformRequest.Caption = "執行查詢"</p>
<p>tmrBusy.Enabled = False</p>
<p>Me.MousePointer = vbDefault</p>
<p>txtURL.Enabled = True</p>
<p>Set PageResources = Nothing</p>
<p>End If</p>
<p>End Sub</p>
<p></p>
<p>Private Sub Form_Load()</p>
<p></p>
<p>tvURLTreeView.Width = GetSetting(App.Path, "Option", "Split", 3000)</p>
<p></p>
<p>Me.Width = GetSetting(App.Path, "Option", "Width", Screen.Width / 2)</p>
<p>Me.Height = GetSetting(App.Path, "Option", "Height", Screen.Height / 2)</p>
<p>Me.Left = GetSetting(App.Path, "Option", "Left", (Screen.Width - Me.Width) / 2)</p>
<p>Me.Top = GetSetting(App.Path, "Option", "Top", (Screen.Height - Me.Height) / 2)</p>
<p></p>
<p>Me.WindowState = GetSetting(App.Path, "Option", "Window", 0)</p>
<p></p>
<p>tvURLTreeView.Nodes.Add , , "WWW", "溫州東化科技有限公司", _</p>
<p>icoROOT, icoROOT</p>
<p></p>
<p>BrowserFile = App.Path & "\Temp.Htm" 注釋：臨時文件</p>
<p>WritToFile ""</p>
<p>txtOutput1.Navigate BrowserFile</p>
<p></p>
<p>End Sub</p>
<p></p>
<p>Private Sub Form_Resize()</p>
<p></p>
<p>On Error Resume Next</p>
<p></p>
<p>If Me.WindowState = 1 Then Exit Sub</p>
<p></p>
<p>If Me.ScaleWidth < _</p>
<p>(lblURL.Width + _</p>
<p>cmdPerformRequest.Width + _</p>
<p>200 + 3 * 60) Then</p>
<p>Me.Width = lblURL.Width + _</p>
<p>cmdPerformRequest.Width + _</p>
<p>500 + 4 * 60 + 4</p>
<p>End If</p>
<p>If Me.ScaleHeight < _</p>
<p>(txtOutput1.Top + 500 + 60) Then</p>
<p>Me.Height = txtOutput1.Top + 500 + 60</p>
<p>End If</p>
<p>lblURL.Left = 40</p>
<p>txtURL.Left = lblURL.Left + lblURL.Width + 40</p>
<p>txtURL.Width = Me.ScaleWidth - _</p>
<p>(txtURL.Left + cmdPerformRequest.Width + picBusy.Width + 3 * 80)</p>
<p>cmdPerformRequest.Left = Me.ScaleWidth - _</p>
<p>(cmdPerformRequest.Width + picBusy.Width + 2 * 80)</p>
<p>cmdPerformRequest.Height = txtURL.Height + 20</p>
<p>picBusy.Left = cmdPerformRequest.Left + cmdPerformRequest.Width + 40</p>
<p>tvURLTreeView.Left = 80</p>
<p>tvURLTreeView.Height = Me.ScaleHeight - _</p>
<p>(sbHTTPStatus.Height + tvURLTreeView.Top + 40)</p>
<p>txtOutput1.Top = tvURLTreeView.Top</p>
<p>txtOutput1.Left = tvURLTreeView.Left + tvURLTreeView.Width + 40</p>
<p>txtOutput1.Width = Me.ScaleWidth - (txtOutput1.Left + 40)</p>
<p>txtOutput1.Height = Me.ScaleHeight - _</p>
<p>(sbHTTPStatus.Height + txtOutput1.Top + 40)</p>
<p>picDivider.Top = tvURLTreeView.Top</p>
<p>picDivider.Height = tvURLTreeView.Height</p>
<p>picDivider.Left = tvURLTreeView.Left + tvURLTreeView.Width</p>
<p>picDivider.Width = 40</p>
<p></p>
<p>End Sub</p>
<p></p>
<p></p>
<p>Private Sub Form_Unload(Cancel As Integer)</p>
<p></p>
<p>If Me.WindowState = 0 Then</p>
<p>SaveSetting App.Path, "Option", "Left", Me.Left</p>
<p>SaveSetting App.Path, "Option", "Top", Me.Top</p>
<p>SaveSetting App.Path, "Option", "Width", Me.Width</p>
<p>SaveSetting App.Path, "Option", "Height", Me.Height</p>
<p>SaveSetting App.Path, "Option", "Window", Me.WindowState</p>
<p>End If</p>
<p></p>
<p>End Sub</p>
<p></p>
<p>Private Sub Inet1_StateChanged(ByVal State As Integer)</p>
<p>Dim Loc As Long</p>
<p>Dim sHeaderValue As String</p>
<p>Dim vtDataChunk As Variant</p>
<p>Dim BinaryData() As Byte</p>
<p>Dim Offset As Long</p>
<p>Dim Counter As Long</p>
<p>Dim BinaryFileID As Integer</p>
<p></p>
<p>Select Case State</p>
<p>Case icNone</p>
<p>Case icResolvingHost</p>
<p>sbHTTPStatus.Panels(1).Text = "解析主機"</p>
<p>Case icHostResolved</p>
<p>sbHTTPStatus.Panels(1).Text = "主機解析"</p>
<p>Case icConnecting</p>
<p>sbHTTPStatus.Panels(1).Text = "正在連接..."</p>
<p>Case icConnected</p>
<p>Loc = InStr(Inet1.URL, ":80")</p>
<p>If Loc > 0 Then</p>
<p>txtURL.Text = Left(Inet1.URL, Loc - 1) & Mid(Inet1.URL, Loc + 3)</p>
<p>Else</p>
<p>txtURL.Text = Inet1.URL</p>
<p>End If</p>
<p>Case icRequesting</p>
<p>sbHTTPStatus.Panels(2).Text = "正在查詢..."</p>
<p>Case icRequestSent</p>
<p>sbHTTPStatus.Panels(2).Text = "查詢發送...."</p>
<p>Case icReceivingResponse</p>
<p>sbHTTPStatus.Panels(2).Text = "接收回答..."</p>
<p>Case icResponseReceived</p>
<p>sbHTTPStatus.Panels(2).Text = "接收回答......"</p>
<p>Case icDisconnecting</p>
<p>sbHTTPStatus.Panels(1).Text = "沒有連接"</p>
<p>Case icDisconnected</p>
<p>sbHTTPStatus.Panels(1).Text = "沒有連接"</p>
<p>Case icError</p>
<p>sbHTTPStatus.Panels(1).Text = "連接錯誤"</p>
<p>Case icResponseCompleted</p>
<p>sbHTTPStatus.Panels(2).Text = "查詢完成"</p>
<p>sHeaderValue = Inet1.GetHeader("Content-type")</p>
<p>If (Not BinaryFile) And InStr(1, sHeaderValue, "text/", 1) Then</p>
<p>vtDataChunk = Inet1.GetChunk(1024, icString)</p>
<p>Do While Len(vtDataChunk) > 0</p>
<p>注釋： 裝載文本</p>
<p>txtOutput.Text = txtOutput.Text + vtDataChunk</p>
<p>vtDataChunk = Inet1.GetChunk(1024, icString)</p>
<p>Loop</p>