浏览器

开发平台：
Visual Basic

frmCloseLike.frm：源码内容
							VERSION 5.00
Begin VB.Form frmCloseLike 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "关闭相似"
   ClientHeight    =   3195
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6660
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   213
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   444
   StartUpPosition =   1  'CenterOwner
   Begin VB.CommandButton cmdInvert 
      Caption         =   "反选"
      Height          =   360
      Left            =   3960
      TabIndex        =   4
      Top             =   2760
      Width           =   735
   End
   Begin VB.CommandButton cmdRefresh 
      Caption         =   "更新"
      Height          =   300
      Left            =   2820
      TabIndex        =   3
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox txtLikeUrl 
      Appearance      =   0  'Flat
      Height          =   300
      Left            =   60
      TabIndex        =   2
      Top             =   2760
      Width           =   2655
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   360
      Left            =   5760
      TabIndex        =   1
      Top             =   2760
      Width           =   855
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "确定(&O)"
      Default         =   -1  'True
      Height          =   360
      Left            =   4800
      TabIndex        =   0
      Top             =   2760
      Width           =   855
   End
End
Attribute VB_Name = "frmCloseLike"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private CloseIndex() As Long
Private CloseIndexCnt As Long
Private m_cLvwMain As cSysListView32
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdInvert_Click()
Dim i&, tcnt&
With m_cLvwMain
    tcnt = .GetItemCount
    For i = 0 To tcnt - 1
        .CheckItem Not .GetCheckState(i), i
    Next i
End With
'Dim tItem As MSComctlLib.ListItem
'For Each tItem In lvwMain.ListItems
'    tItem.Checked = Not tItem.Checked
'Next tItem
End Sub
Private Sub cmdOk_Click()
Dim i&, tcnt&
Me.Visible = False
tcnt = m_cLvwMain.GetItemCount
For i = 0 To tcnt - 1
    If m_cLvwMain.GetCheckState(i) Then
        gMainForm.UnloadBrowser (CloseIndex(i + 1))
    End If
Next i
Unload Me
'Dim i&, tCnt&
'Me.Visible = False
'tCnt = lvwMain.ListItems.Count
'For i = 1 To tCnt
'    If lvwMain.ListItems(i).Checked Then
'        gMainForm.UnloadBrowser (CloseIndex(i))
'    End If
'Next i
'Unload Me
End Sub
Private Sub cmdRefresh_Click()
Call AddLvwItem(txtLikeUrl.Text)
End Sub
Private Sub Form_Load()
Call IniLvw
End Sub
Private Sub IniLvw()
Set m_cLvwMain = CreateCmmCtrl(strCLSID_cSysListView32) ' New cSysListView32
With m_cLvwMain
    .Create Me.hwnd, LVS_REPORT Or LVS_SHOWSELALWAYS Or LVS_SINGLESEL, _
            LVS_EX_CHECKBOXES, 4, 0, 433, 177
    .AddColumn 0, "标题", 110
    .AddColumn 1, "地址", 220
End With
'With lvwMain
'    .LabelEdit = lvwManual
'    .View = lvwReport
'    .Appearance = ccFlat
'    .Checkboxes = True
'    .ColumnHeaders.Add , , "标题", Me.ScaleWidth / 4
'    .ColumnHeaders.Add , , "地址", .Width - Me.ScaleWidth / 4
'End With
End Sub
Public Sub IniMe(ByVal nIndex As Integer, nParent As Form)
Dim tUrl$
tUrl = webbState(nIndex).webForm.GetWebUrl
Call AddLvwItem(GetDomain(tUrl))
txtLikeUrl.Text = GetDomain(tUrl)
Me.Show vbModal, nParent
End Sub
Private Sub AddLvwItem(nDomain As String)
Dim i&
Dim tDomain$, tUrl$
Dim tItem&
tDomain = LCase(nDomain)
CloseIndexCnt = 0
ReDim CloseIndex(0 To 0)
With m_cLvwMain
    m_cLvwMain.ClearItem
    For i = 1 To browserCount
        If Not webbState(i) Is Nothing Then
            tUrl = webbState(i).webForm.GetWebUrl
            If InStr(1, LCase(GetMainUrl(tUrl)), nDomain) > 0 Then
               CloseIndexCnt = CloseIndexCnt + 1
               ReDim Preserve CloseIndex(0 To CloseIndexCnt)
               CloseIndex(CloseIndexCnt) = i
               
               tItem = .AddItem(webbState(i).webForm.GetWebTitle)
               .CheckItem True, tItem
               .SetItemText tUrl, tItem, 1
            End If
        End If
    Next i
End With
'Dim i&
'Dim tDomain$, tUrl$
'Dim tItem As MSComctlLib.ListItem
'
'tDomain = LCase(nDomain)
'CloseIndexCnt = 0
'ReDim CloseIndex(0 To 0)
'With lvwMain
'    .ListItems.Clear
'    For i = 1 To browserCount
'        'If webbState(i).isLoaded Then
'        If Not webbState(i) Is Nothing Then
'            tUrl = webbState(i).webForm.GetWebUrl
'            If InStr(1, LCase(GetMainUrl(tUrl)), nDomain) > 0 Then
'               CloseIndexCnt = CloseIndexCnt + 1
'               ReDim Preserve CloseIndex(0 To CloseIndexCnt)
'               CloseIndex(CloseIndexCnt) = i
'               Set tItem = .ListItems.Add(, , webbState(i).webForm.GetWebTitle)
'               tItem.Checked = True
'               tItem.SubItems(1) = tUrl
'            End If
'        End If
'    Next i
'End With
End Sub
Private Function GetDomain(nUrl As String) As String
Dim tstr$
Dim tPointCnt&, tPos&, tPosStart&
tstr = GetMainUrl(nUrl)
tPos = 1: tPosStart = -1
tPointCnt = 0
While tPos > 0
    tPos = InStr(tPos, tstr, ".")
    If tPos > 0 Then
        tPointCnt = tPointCnt + 1
        If tPointCnt = 1 Then
            tPosStart = tPos
        End If
        tPos = tPos + 1
    End If
Wend
If tPointCnt > 1 Then
    GetDomain = Mid$(tstr, tPosStart + 1)
Else
    GetDomain = tstr
End If
Debug.Print "getdomain"
End Function
'获取 "http://" 到 "/"的东西
Private Function GetMainUrl(nUrl As String) As String
Dim tPos1&, tPos2&
tPos1 = InStr(1, nUrl, "://") + 3
tPos2 = InStr(tPos1, nUrl, "/")
If tPos2 > 0 Then
    GetMainUrl = Mid$(nUrl, tPos1, tPos2 - tPos1)
Else
    GetMainUrl = Mid$(nUrl, tPos1)
End If
End Function
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Set m_cLvwMain = Nothing
End Sub

						