浏览器

开发平台：
Visual Basic

frmBrowser.frm：源码内容
							VERSION 5.00
Begin VB.Form frmBrowser 
   BackColor       =   &H00800000&
   Caption         =   " "
   ClientHeight    =   6105
   ClientLeft      =   1740
   ClientTop       =   3270
   ClientWidth     =   6300
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   9
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   HasDC           =   0   'False
   Icon            =   "frmBrowser.frx":0000
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   NegotiateMenus  =   0   'False
   ScaleHeight     =   6105
   ScaleWidth      =   6300
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdScale 
      Appearance      =   0  'Flat
      Height          =   600
      Left            =   240
      MaskColor       =   &H00FF00FF&
      Style           =   1  'Graphical
      TabIndex        =   0
      Top             =   240
      UseMaskColor    =   -1  'True
      Visible         =   0   'False
      Width           =   600
   End
End
Attribute VB_Name = "frmBrowser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
' Module    : frmBrowser
' DateTime  : <<2005-7-31 23:13
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
'2005-7-31 23:13:25 添加 GetAllDocument ,主要供script使用
Option Explicit
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
'Public lpPrevFormProc As Long
Public nTimer As Single
'自动过滤,0表示不过滤,1-3代表不同等级
Public mPvnPop As Long
'自动过滤的等级
Private pvnPopTime(0 To 3) As Single
'前进后退状态
Public mCanBack As Boolean
Public mCanForward As Boolean
Public WithEvents webMe As SHDocVw.WebBrowser
Attribute webMe.VB_VarHelpID = -1
Public WithEvents vCWebMe As cWebBrowser
Attribute vCWebMe.VB_VarHelpID = -1
'webbstate中的index
Public tagIndex As Long
'是否url过滤
Public isFiltrate As Boolean
Dim isUnloading As Boolean
Dim historyLength As Long
Public widthPixel As Long, heightPixel As Long
'是否可以显示,如果是在过滤的范围则不能显示
'Public CanNotShow As Boolean
'"自动阻隔",是否阻隔
Private mAutoCanNew As Single
'web "Shell Embedding" hwnd
Private mHWeb As Long
'页面的url
Private mWebUrl As String
'页面title
Private mWebTitle As String
'调用此窗口的窗口index,及url
Private mPreIndex As Long
Private mPreUrl As String
'下载控制本地变量
Private mDownloadCtrl As DownloadCtrlFlags
Private mDL_Image As Boolean
Private mDL_BgSound As Boolean
Private mDL_Video As Boolean
Private mDL_Script As Boolean
Private mDL_ActiveX As Boolean
Private mDL_JavaApplet As Boolean
Private mDl_DlActiveX  As Boolean
'本页面属性,如,记录下载控制,是否自动阻隔
Private Type mTypPageProperty
    DLCtrl As Long      '下载控制
    PvnPop As Long      '自动过滤
    ParentIndex As Long 'New自己的窗口的Index
End Type
'是否图片
Private mIsImage As Boolean
'是否第一次连接,
Private mFirstNav As Boolean
'是否独立新开的窗口(从收藏夹,收藏栏,地址栏新开的窗口)
'主要用以判断是否由别的窗口"newwindow"而来,对"页面规则"有用
Private mIsSingleWindow As Boolean
'判断是否已经做过DoPageRule
'主要作用是用于 Public Sub Navigate(Url As String)
'避免重复操作
Private mIsDoPageRule As Boolean
'"总是在新页面打开"
Public IsAllOpenNew As Long
'在后面打开新窗口
Public NewWindowInBack As Long
'========前进后退相关=====================
Private Stg As olelib.ITravelLogStg
'Private Titles() As String
'Private TitleCnt As Long
'
'Private preTitle As String
'
'Private preStep As Long
'Private preTotalStep As Long
'Private preForeStep As Long
'==========================================
'拖拽中,在<input>中的光标位置
'Private mDDChrPos As Long
Private mPreProgressIcon As Long
'是否自身的script新开的窗口
Public newInSelfScript As Boolean
'保存TranslateURL
Private mTransUrl As String
'后台打开,并且最大化时使用
Public NoActive As Boolean
'脚本设定的长宽
Private mSetWebWidth As Long
Private mSetWebHeight As Long
Private Sub Form_Initialize()
mPreProgressIcon = -1
'CanNotShow = False ' True
mFirstNav = True
mIsSingleWindow = True
mIsDoPageRule = False
isFiltrate = False
'firstLoseFocus = True
mPvnPop = PreventPopWindow
mCanBack = False
mCanForward = False
historyLength = 1
pvnPopTime(1) = 0.7
pvnPopTime(2) = 0.3
pvnPopTime(3) = 0.1
Call IniVar
Call IniDownloadControl
'mHWeb = FindWindowEx(Me.hwnd, 0&, "Shell Embedding", vbNullString)
End Sub
'Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
''If Shift = vbCtrlMask Then
''    Select Case KeyCode
''        Case vbKeyN
''            Dim tmpI As Integer
''            tmpI = gActiveWebIndex
''            Call gMainForm.NewWebbrowser(webMe.LocationURL)
''
''            'wbbMe(gActiveWebIndex).Navigate wbbMe(tmpI).LocationURL
''            KeyCode = 0
''        'Case vbKeyF4:
''            'Call unloadBrowser(gActiveWebIndex)
''            'KeyCode = 0
''    End Select
''End If
'
'End Sub
Private Sub Form_Load()
Set vCWebMe = New cWebBrowser
vCWebMe.HostInfo = vCWebMe.HostInfo Or hfFlatScroll Or hfNo3DBorder
vCWebMe.DownloadCtrl = mDownloadCtrl ' DLCTL_Default Or DLCTL_SILENT
'vCWebMe.UserAgent = "Mozilla/4.0 (compatible; MSIE 5.00; Windows 98)"
vCWebMe.INIAll Me
Set webMe = vCWebMe.WBCtrl
'mHookAllForms.Add Me, Str(Me.hwnd)
'Call WebformHook(Me.hwnd, lpPrevFormProc)
Call WebformHook(Me.hWnd, Me)
'前进后退历史记录相关
'TitleCnt = 0
'ReDim Titles(0 To TitleCnt)
Call LogConnect
'===========================
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error GoTo due:
'Debug.Print "queryunload", CanNotShow
'If Not CanNotShow Then
WebformUnhook Me.hWnd
    isUnloading = True
    If Not webMe.Document Is Nothing Then
        Set webMe.Document.body.onunload = Nothing
        webMe.Document.Open
        webMe.Document.Clear
        webMe.Document.Close
    End If
    
    
    If (Not isUnloadByFunction) And (Not isExit) Then
        Call gMainForm.UnloadBrowser(ByVal tagIndex)
    End If
    isUnloadByFunction = False
    If loadedBrowserCount < 1 Then gActiveWebIndex = 0
'End If
'mHookAllForms.Remove Str(Me.hwnd)
'WebformUnhook Me.hwnd, lpPrevFormProc
'WebformUnhook Me.hWnd
Exit Sub
due:
ErrorLog.AddLog Err.Description & Str(Err.Number) & Chr(9) & "WebForm Unload"
Resume Next
End Sub
Private Sub Form_Resize()
widthPixel = Me.ScaleWidth / 15
heightPixel = Me.ScaleHeight / 15
If isUnloading Then Exit Sub
'Call OrgWeb
End Sub
Private Sub vCWebMe_DownloadBegin(url As String, Cancel As Long)
'Debug.Print "download url:", Url
Dim tFrm As frmDownloadDlg
If gShowDownDlg = 1 Then
    Set tFrm = New frmDownloadDlg
    Load tFrm
    tFrm.IniMe url
    tFrm.Show vbModal
    Cancel = BooleanToBool(tFrm.IsCancel)
    Unload tFrm
    Set tFrm = Nothing
    
    If Cancel = 0 Then
        If gUseDownTool = 1 Then
            ShellExecute 0, "open", AppPath & "DownManager" & gDownTools(gDownToolIndex).url, _
                    """" & url & """ """" """ & mWebUrl & """", _
                    AppPath & "DownManager", SW_SHOW
            Cancel = 1
        End If
    End If
Else
    If gUseDownTool = 1 Then
        ShellExecute 0, "open", AppPath & "DownManager" & gDownTools(gDownToolIndex).url, _
                """" & url & """ """" """ & mWebUrl & """", _
                AppPath & "DownManager", SW_SHOW
        Cancel = 1
    End If
End If
End Sub
'Private Sub tmrReSetWebEvent_Timer()
'Call SetWebEvent
'tmrReSetWebEvent.Enabled = False
'End Sub
'Public Sub EnableSetWebEvent()
'tmrReSetWebEvent.Enabled = True
'End Sub
'Private Sub tmrUnload_Timer()
''If CanNotShow Then
'    If loadedBrowserCount > 0 Then
'        'webbState(gActiveWebIndex).webForm.SetFocus
'        'DoEvents
'    End If
''End If
'Unload Me
'End Sub
Private Sub vCWebMe_GetExternal(External As Object)
Set External = Me
End Sub
Private Sub vCWebMe_KeyDown(KeyCode As Integer, Shift As Integer)
If Shift = vbCtrlMask Then
    Select Case KeyCode
        Case vbKeyN
            Dim tmpI As Integer
            tmpI = gActiveWebIndex
            Call gMainForm.NewWebbrowser(webMe.LocationURL)
            
            'wbbMe(gActiveWebIndex).Navigate wbbMe(tmpI).LocationURL
            KeyCode = 0
        'Case vbKeyF4:
            'Call unloadBrowser(gActiveWebIndex)
            'KeyCode = 0
    End Select
End If
End Sub
Private Sub vCWebMe_OLEDragDrop(ByVal Data As DataObjectWB, ByVal KeyState As Long, ByVal x As Long, ByVal y As Long, Effect As Long)
Dim turl$
Dim tDir&
Dim tFiles As Collection
Debug.Print Data.GetImageUrl()
Set tFiles = Data.Files
If DoOrgDrop(Data, x, y) Then
    If KeyState = MK_CONTROL Then
        Effect = DROPEFFECT_COPY
    Else
        Effect = DROPEFFECT_MOVE
    End If
    'Effect = DROPEFFECT_COPY Or DROPEFFECT_MOVE
Else
    If gSelfDrag.SelfDraging Then
        turl = gSelfDrag.SrcStr
        If turl <> "" Then
            If gSelfDrag.DragFormIndex = tagIndex Then  '判断是否来自本页
                If EnableDragLink = 1 Then
                    tDir = GetDragDropDir(gSelfDrag.dragX, gSelfDrag.dragY, x, y)
                    If tDir >= 0 And tDir < 4 Then
                        If (Effect And DROPEFFECT_LINK) = DROPEFFECT_LINK Then
                            gSelfDrag.SrcType = "url"
                        End If
                        Select Case gSelfDrag.SrcType
                            Case "img"
                                If tFiles.Count > 0 Then
                                    gSelfDrag.SrcFilePath = tFiles(1)
                                End If
                                gDDEventImage(tDir).Execute
                            Case "url"
                                gDDEventLink(tDir).Execute
                            Case Else
                                gDDEventText(tDir).Execute
                        End Select
                    End If
                End If
            Else
                Call Navigate(turl, False)
            End If
        End If
    Else
        turl = Trim(Data.GetText)
        If turl = "" Then
            If tFiles.Count > 0 Then
                turl = Trim(tFiles(1))
            End If
        End If
        If turl <> "" Then
            Call Navigate(turl, False)
        End If
    End If
End If
End Sub
Private Function GetDragDropDir(sX&, sY&, dx&, dy&) As Long
Dim cx&, cy&
Dim rtn&
rtn = -1
cx = dx - sX: cy = -(dy - sY)
If cx > 0 And Abs(cy) <= cx Then
    rtn = 0
ElseIf cy > 0 And Abs(cx) <= cy Then
    rtn = 1
ElseIf cx < 0 And Abs(cy) <= Abs(cx) Then
    rtn = 2
ElseIf cy < 0 And Abs(cx) <= Abs(cy) Then
    rtn = 3
End If
GetDragDropDir = rtn
End Function
Private Sub vCWebMe_OLEDragEnter(ByVal Data As DataObjectWB, ByVal KeyState As Long, ByVal x As Long, ByVal y As Long, Effect As Long)
gSelfDrag.dragX = x: gSelfDrag.dragY = y
On Error Resume Next
If GetForegroundWindow() = gMainForm.hWnd Then
    If GetWindow(Me.hWnd, GW_HWNDFIRST) = Me.hWnd Then
        With gSelfDrag
            .Reset
            .SelfDraging = True
            .DragFormIndex = tagIndex
            .SrcType = Data.GetHtmlDragDropType
            
            If .SrcType = "img" Then
                .SrcStr = Data.GetImageUrl
            Else
                .SrcType = "text"
                .SrcStr = Data.GetText
            End If
            
            .SrcHtmlText = Data.GetFragment(Data.GetCFHtml)
            
            Set gSelfDrag.SelRange = GetSelection
        End With
    End If
Else
    gSelfDrag.Reset
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetSelection
' DateTime  : 2005-5-12 12:08
' Author    : Lingll
' Purpose   : 获取页面上首个selection
'---------------------------------------------------------------------------------------
Public Function GetSelection() As Object
On Error Resume Next
    Dim objResult As Object
    Dim tWeb As SHDocVw.WebBrowser
    Dim tCol As New Collection
    
    tCol.Add webMe
    EnumFrames webMe, tCol
    
    For Each tWeb In tCol
        Set objResult = Nothing
        Set objResult = tWeb.Document.Selection.createRange
        If Not objResult Is Nothing Then
            If LenB(objResult.htmlText) <> 0 Then
                Exit For
            End If
        End If
    Next tWeb
    
    
    Set GetSelection = objResult
    Set objResult = Nothing
End Function
Private Sub vCWebMe_OLEDragOver(ByVal Data As DataObjectWB, ByVal KeyState As Long, ByVal x As Long, ByVal y As Long, Effect As Long)
'Dim tDoc As MSHTML.HTMLDocument
Dim tpt  As POINTAPI
Dim e As Object, tTag$
tpt.x = x: tpt.y = y
Set e = GetWindowPoint(tpt.x, tpt.y)
'Set tDoc = webMe.Document
'Set e = tDoc.elementFromPoint(tpt.x, tpt.y)
If Not e Is Nothing Then
    tTag = LCase(e.tagName)
'    Debug.Print tTag, tpt.x, tpt.y
    Select Case tTag
        Case "textarea"
            Call OverWebEdit(e, tpt.x, tpt.y)
            If IsInSelection(webMe.Document) Then
                Effect = DROPEFFECT_NONE
            Else
                If (KeyState And MK_CONTROL) = MK_CONTROL Then
                    'Effect = Effect Xor DROPEFFECT_MOVE
                Else
                    If (Effect And DROPEFFECT_MOVE) = DROPEFFECT_MOVE Then
                        Effect = Effect Xor DROPEFFECT_COPY
                    End If
                End If
            End If
        Case "input"
            If LCase(e.Type) = "text" Then
                Call OverWebEdit2(e, tpt.x, tpt.y)
                If IsInSelection(webMe.Document) Then
                    Effect = DROPEFFECT_NONE
                Else
                    'Effect = Effect Or DROPEFFECT_COPY Or DROPEFFECT_MOVE
                    If (KeyState And MK_CONTROL) = MK_CONTROL Then
                        'Effect = Effect Xor DROPEFFECT_MOVE
                    Else
                        If (Effect And DROPEFFECT_MOVE) = DROPEFFECT_MOVE Then
                            Effect = Effect Xor DROPEFFECT_COPY
                        End If
                    End If
                End If
            End If
    End Select
End If
End Sub
'###############################################################
'######  begin  拖拽相关函数 #########
'####################################
'模拟ie原本的拖放(drop部分)
Private Function DoOrgDrop(ByVal Data As DataObjectWB, ByVal x As Long, ByVal y As Long) As Boolean
'Dim tDoc As MSHTML.HTMLDocument
Dim tpt  As POINTAPI
Dim e As Object, tTag$
Dim rtn As Boolean
rtn = False
tpt.x = x: tpt.y = y
Set e = GetWindowPoint(tpt.x, tpt.y)
'Set tDoc = webMe.Document
'Set e = tDoc.elementFromPoint(tpt.x, tpt.y)
If Not e Is Nothing Then
    tTag = LCase(e.tagName)
    Select Case tTag
        Case "textarea"
            If e.ReadOnly Then
            Else
                Call DropWebEdit(e, tpt.x, tpt.y, Data.GetText)
                rtn = True
            End If
        Case "input"
            If LCase(e.Type) = "text" Then
                If e.ReadOnly Then
                Else
                    Call DropWebEdit2(e, tpt.x, Data.GetText)
                    rtn = True
                End If
            End If
    End Select
End If
DoOrgDrop = rtn
End Function
Private Function IsInSelection(nDoc As MSHTML.HTMLDocument) As Boolean
On Error Resume Next
Dim tSel As Object
Dim tRc As RECT, tRc2 As RECT
Dim rtn As Boolean
rtn = False
Set tSel = nDoc.Selection.createRange
If Not tSel Is Nothing Then
    If Not gSelfDrag.SelRange Is Nothing Then
        With tSel
            tRc.Left = .boundingLeft
            tRc.Top = .boundingTop
            tRc.Right = tRc.Left + .boundingWidth
            tRc.Bottom = tRc.Top + .boundingHeight
        End With
        
        With gSelfDrag.SelRange
            tRc2.Left = .boundingLeft
            tRc2.Top = .boundingTop
            tRc2.Right = tRc2.Left + .boundingWidth
            tRc2.Bottom = tRc2.Top + .boundingHeight
        End With
        
        rtn = tRc.Left > tRc2.Left And tRc.Right < tRc2.Right And _
            tRc.Top >= tRc2.Top And tRc.Bottom <= tRc2.Bottom
'        Debug.Print "left", tRc.Left, tRc2.Left
'        Debug.Print "right", tRc.Right, tRc2.Right
'        Debug.Print "rtn", rtn
        
    End If
End If
IsInSelection = rtn
End Function
'获得页面中对应的坐标,参数x,y为屏幕坐标
Private Function GetWindowPoint(x&, y&) As Object ' POINTAPI
Dim rtn As POINTAPI
Dim tWin As MSHTML.HTMLWindow2
Set tWin = FindFrameFromPoint(x, y)
rtn.x = x: rtn.y = y
ScreenToClient Me.hWnd, rtn
'Set GetWindowPoint = webMe.Document.elementFromPoint(rtn.x, rtn.y)
If tWin Is Nothing Then
    Set GetWindowPoint = webMe.Document.body
Else
'    Debug.Print tWin.screenLeft, tWin.screenTop
    rtn.x = rtn.x - (tWin.screenLeft - webMe.Document.parentWindow.screenLeft)
    rtn.y = rtn.y - (tWin.screenTop - webMe.Document.parentWindow.screenTop)
    Set GetWindowPoint = tWin.Document.elementFromPoint(rtn.x, rtn.y)
End If
x = rtn.x: y = rtn.y
End Function
'模拟ie原本的拖放(over部分)
Private Sub OverWebEdit(e As Object, x As Long, y As Long)
On Error Resume Next
Dim r As MSHTML.IHTMLTxtRange
Set r = e.createTextRange
Call r.moveToPoint(x, y)
Call r.Select
End Sub
Private Sub DropWebEdit(e As Object, x&, y&, ByVal InsertTxt$)
Dim r As Object
Set r = e.createTextRange
If e.Value <> "" Then
    Call r.moveToPoint(x, y)
    r.Text = ""
    r.Text = InsertTxt
Else
    e.Value = InsertTxt
End If
'Call r.MoveStart("character", -Len(InsertTxt))
'Call r.MoveEnd("character", Len(InsertTxt))
Call r.Select
End Sub
'just for <input>
Private Sub OverWebEdit2(e As Object, x As Long, y As Long)
Dim r As Object
Dim cx As Long, tPos As Long
Set r = e.createTextRange
cx = x - r.boundingLeft - e.scrollLeft
tPos = GetWebEditPos(r, cx)
'mDDChrPos = tPos
Call r.Collapse(True)
Call r.Move("character", tPos)
Call r.Select
End Sub
Private Sub DropWebEdit2(e As Object, x&, ByVal InsertTxt$)
Dim tPos&, cx&
Dim r As Object
Set r = e.createTextRange
cx = x - r.boundingLeft - e.scrollLeft
tPos = GetWebEditPos(r, cx)
Call r.Move("character", tPos)
InsertTxt = Replace(InsertTxt, Chr(0), "")
InsertTxt = Replace(InsertTxt, Chr(13), "")
InsertTxt = Replace(InsertTxt, Chr(10), "")
r.Text = InsertTxt
End Sub
'主要是为OverWebEdit2服务,获得鼠标指针所在字符位置
Private Function GetWebEditPos(Rng As Object, x As Long) As Long
Dim i&, tLen&
Dim nBw&, preBw&
tLen = Len(Rng.Text)
Call Rng.Collapse(True)
For i = 1 To tLen
    Call Rng.MoveEnd("character", 1)
    nBw = Rng.boundingWidth
    If nBw >= x Then
        If (nBw - x) > (x - preBw) Then
            GetWebEditPos = i - 1
            Exit Function
        Else
            GetWebEditPos = i
            Exit Function
        End If
    Else
        preBw = nBw
    End If
Next i
GetWebEditPos = tLen
End Function
'####################################
'######  end  拖拽相关函数 ###########
'#############################################################
Private Sub vCWebMe_TranslateURL(url As String)
'Debug.Print "translateurl", URL, tagIndex
mTransUrl = url
End Sub
Private Sub webme_BeforeNavigate2(ByVal pDisp As Object, url As Variant, flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
mTransUrl = ""
On Error GoTo due
If tagIndex = 0 Then Exit Sub
Dim newIndex As Long
Dim i&, turl$
Dim doRtn& 'DoPageRule return value
turl = LCase(url)
'If CanNotShow Then
''    If mAutoCanNew Then
''        If EnableUrlFilter = 1 Then
''            For i = 1 To UrlFilterCount
''                If MatchUrl(UrlFilter(i), tUrl) Then
''                    FiltratePages.Add mPreUrl, tUrl
''                    Cancel = True
''                    tmrUnload.Enabled = True 'Unload Me
''                    Exit Sub
''                End If
''            Next i
''        End If
'        doRtn = DoPageRule(Url, pDisp Is webMe, 0)
'        Select Case doRtn
''            Case 1
''                Cancel = True
''                tmrUnload.Enabled = True
''                Exit Sub
'            Case 0, -1
'                CanNotShow = False
''                newIndex = gMainForm.NewWebbrowser(, Me, , , webbState(mPreIndex).TabBtn.index + 1)
'                'gMainForm.MoveTab newIndex, GetNextTab(mPreIndex)
'        End Select
''    Else
''        FiltratePages.Add mPreUrl, tUrl
''        Cancel = True
''        tmrUnload.Enabled = True 'Unload Me
''        Exit Sub
''    End If
'Else
    If Not mIsDoPageRule Then
        
        doRtn = DoPageRule(url, pDisp Is webMe)
        Select Case doRtn
            Case 1
                Cancel = True
                Exit Sub
'                If mFirstNav Then
'                    Cancel = True
'                    Call gMainForm.UnloadBrowser(ByVal tagIndex)
'                    Exit Sub
'                Else
'                    Cancel = True
'                    Exit Sub
'                End If
            Case Else
                '
        End Select
    End If
'End If
'If Not CanNotShow Then
    If AllwaysNewWindow(pDisp, url) Then
        Cancel = True
    Else
        '前进后退历史记录
        'Call SetTitles(mWebTitle)
        
        If pDisp Is webMe Then
            If mWebTitle = "" Then mWebTitle = url
            Call ChangeTabTitle
            vCWebMe.DownloadCtrl = mDownloadCtrl
        End If
    End If
'End If
mIsDoPageRule = False
mFirstNav = False
Exit Sub
due:
    ErrorLog.AddLog "webme_BeforeNavigate2" & Chr(9) & Err.Description
    Resume Next
End Sub
Private Function AllwaysNewWindow(nObj As Object, ByVal nUrl As String) As Boolean
Dim rtn As Boolean
'Dim i&
rtn = False
'If IsAllOpenNew = 1 Then
'    For i = 1 To mWebObjCnt
'        With mWebObjects(i)
'            If Not .IsEmpty And Not .FirstLoad Then
'                If nObj Is .WebObject Then
'                    gMainForm.NewWebbrowser nUrl
'                    rtn = True
'                End If
'            End If
'        End With
'    Next i
'End If
On Error Resume Next
Dim alllength As Long
If IsAllOpenNew = 1 Then
    alllength = 0
    alllength = nObj.Document.All.Length
    rtn = (alllength > 0)
    If rtn Then gMainForm.NewWebbrowser nUrl
End If
AllwaysNewWindow = rtn
End Function
Private Sub webMe_CommandStateChange(ByVal Command As Long, ByVal Enable As Boolean)
On Error Resume Next
'Dim t_length As Long
Select Case Command
    Case 2 'CSC_NAVIGATEBACK
        mCanBack = Enable
        Call BackAndForwardState
        
'        preStep = GetStep(TLEF_RELATIVE_INCLUDE_CURRENT)
    Case 1 ' CSC_NAVIGATEFORWARD
        mCanForward = Enable
        Call BackAndForwardState
        
'        preStep = GetStep(TLEF_RELATIVE_INCLUDE_CURRENT)
'        preForeStep = GetStep(TLEF_RELATIVE_FORE)
End Select
End Sub
Private Sub webMe_DocumentComplete(ByVal pDisp As Object, url As Variant)
On Error Resume Next
Dim tScaleImage As cScaleWebImage
Dim tDoc As MSHTML.HTMLDocument
If Not mIsImage Then
    If pDisp Is webMe Then
        Set tDoc = webMe.Document
        If tDoc.body.All.Length = 1 Then
            If LCase(tDoc.body.All(0).tagName) = "img" Then
                mIsImage = True
            End If
        End If
    End If
End If
If mIsImage Then
    If pDisp Is webMe Then
        Set tScaleImage = New cScaleWebImage
        Set tDoc = webMe.Document
        tScaleImage.IniMe tDoc, Me
        Set tDoc.images(0).onmouseover = tScaleImage
        Set tDoc.images(0).onmouseout = tScaleImage
    End If
End If
'========      progress icon    =====================
If tagIndex > 0 Then
    If gActiveWebIndex = tagIndex Then
        'Set webbState(tagIndex).webTab.PictureIN = Nothing
        If Not webbState(tagIndex).TabBtn Is Nothing Then
            Set webbState(tagIndex).TabBtn.ImageNormal = Nothing
            mPreProgressIcon = -1
        End If
    Else
        'Set webbState(tagIndex).webTab.PictureIN = ProgressIcon(4)
        If Not webbState(tagIndex).TabBtn Is Nothing Then
            Set webbState(tagIndex).TabBtn.ImageNormal = ProgressIcon(4)
            mPreProgressIcon = 4
        End If
    End If
End If
'======================================================
'On Error GoTo due: ' Resume Next
'Dim tDrag As cOpenDragLink
'Set tDrag = New cOpenDragLink
'tDrag.SetDoc pDisp.Document
'pDisp.Document.body.ondrag = tDrag
'pDisp.Document.body.ondragleave = tDrag
'pDisp.Document.body.ondragend = tDrag
''pDisp.Document.body.ondragstart = tDrag
'
''If Not pDisp Is webMe.Object Then
''    If Not (TypeOf webMe.Object.Document.body.ondrag Is cOpenDragLink) Then
''        Set tDrag = New cOpenDragLink
''        tDrag.SetDoc webMe.Document
''        webMe.Document.body.ondrag = tDrag
''        webMe.Document.body.ondragleave = tDrag
''        webMe.Document.body.ondragend = tDrag
''    End If
''End If
'Call OrgWeb
'Exit Sub
'
'due:
'    ErrorLog.AddLog "DocumentComplete" & Chr(9) & Err.Description
'    Resume Next
End Sub
Private Sub webme_NavigateComplete2(ByVal pDisp As Object, url As Variant)
On Error Resume Next
'Dim tObj As cActiveWebEvent
Dim i&
If pDisp Is webMe Then
    mWebUrl = url
    mIsImage = UrlIsImage(mWebUrl)
    
    
    If mWebTitle = "" Then mWebTitle = url
    mWebUrl = url
    Call ChangeTabTitle
    If gActiveWebIndex = tagIndex And (Not addbarGetFocus) Then
        gMainForm.LocationURLText = url
    End If
Else
'    For i = 1 To UrlFilterCount
'        If MatchUrl(UrlFilter(i), CStr(Url)) Then
'            pDisp.Document.Open
'            pDisp.Document.Clear
'            'pDisp.Document.Write "hwhw"
'            pDisp.Document.Close
'            Exit For
'        End If
'    Next i
End If
'Set tObj = New cActiveWebEvent
'tObj.pDisp = pDisp
'tObj.ParentForm = Me
'Set pDisp.Document.ondragstart = tObj
If gActiveWebIndex = tagIndex Then
    gMainForm.LocationURLText = mWebUrl
End If
'progress icon
If pDisp Is webMe Then
    mPreProgressIcon = 0
    'Set webbState(tagIndex).webTab.PictureIN = ProgressIcon(mPreProgressIcon)
    If Not webbState(tagIndex).TabBtn Is Nothing Then
        Set webbState(tagIndex).TabBtn.ImageNormal = ProgressIcon(mPreProgressIcon)
    End If
    
End If
End Sub
Private Sub webMe_NavigateError(ByVal pDisp As Object, url As Variant, Frame As Variant, StatusCode As Variant, Cancel As Boolean)
Debug.Print "NavigateError", StatusCode
End Sub
Private Sub webme_NewWindow2(ppDisp As Object, Cancel As Boolean)
Dim tTransUrl As String
Dim i&
tTransUrl = mTransUrl
mTransUrl = ""
'If isUnloading Then Cancel = True: Exit Sub
'If tagIndex = 0 Then Exit Sub
If loadedBrowserCount >= browserCount Then
    Cancel = True
    Exit Sub
End If
    
Dim tTimer As Single, tAutoCanNew As Boolean
tTimer = Timer - nTimer
tAutoCanNew = True
If mPvnPop > 0 And Not newInSelfScript Then
    If tTimer > pvnPopTime(mPvnPop) Then
        If (GetAsyncKeyState(VK_RETURN) And &H8000) = 0 Then
            tAutoCanNew = False
        End If
    End If
End If
If isUnloading Then Cancel = True: Exit Sub
If tagIndex = 0 Then Exit Sub
If loadedBrowserCount > browserCount + 1 Then Cancel = True: Exit Sub
'Dim newIndex As Integer
'
'newIndex = gMainForm.NewWebbrowser
'DoEvents
'Set ppDisp = webbState(newIndex).webForm.webMe.Object
If tAutoCanNew Then
    If EnableUrlFilter = 1 Then
        For i = 1 To UrlFilterCount
            If MatchUrl(UrlFilter(i), tTransUrl) Then
                FiltratePages.Add mWebUrl, tTransUrl
                Cancel = True
                Exit Sub
            End If
            If DoPageRule(tTransUrl, False, 1) = 1 Then
                Cancel = True
                Exit Sub
            End If
        Next i
    End If
Else
    FiltratePages.Add mWebUrl, tTransUrl
    Cancel = True
    Exit Sub
End If
Dim newMe As New frmBrowser
Dim tProperty As mTypPageProperty
With tProperty
    .DLCtrl = mDownloadCtrl ' vCWebMe.DownloadCtrl
    .PvnPop = mPvnPop
    .ParentIndex = tagIndex
End With
Load newMe
'DoEvents
Set ppDisp = newMe.IniNewWeb(tAutoCanNew, tagIndex, VarPtr(tProperty))
' = newMe.webMe.Object
End Sub
Private Sub webme_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
Dim tDiv As Double
Dim tProgressIcon As Integer
If Progress <> -1 Then Call vCWebMe.ResizeWeb 'OrgWeb
'If tagIndex = 0 Or CanNotShow Then Exit Sub
If tagIndex = 0 Then Exit Sub
If ProgressMax <> 0 Then
    If Progress = -1 Then
        tDiv = 1
    Else
        tDiv = Progress / ProgressMax
        If Progress > ProgressMax Then
            tDiv = tDiv / 100
        End If
    End If
    
    '============  progress icon  ==================
    If tagIndex > 0 Then
        tProgressIcon = Int(tDiv * 4)
        If tProgressIcon >= 0 And tProgressIcon <= 4 Then
            If mPreProgressIcon <> tProgressIcon Then
                'Set webbState(tagIndex).webTab.PictureIN = ProgressIcon(tProgressIcon)
                If Not webbState(tagIndex).TabBtn Is Nothing Then
                    Set webbState(tagIndex).TabBtn.ImageNormal = ProgressIcon(tProgressIcon)
                    mPreProgressIcon = tProgressIcon
                End If
                
                If mPreProgressIcon = 4 Then
                    If gActiveWebIndex = tagIndex Then
                        'Set webbState(tagIndex).webTab.PictureIN = Nothing
                        If Not webbState(tagIndex).TabBtn Is Nothing Then
                            Set webbState(tagIndex).TabBtn.ImageNormal = Nothing
                            mPreProgressIcon = -1
                        End If
                    End If
                End If
    
            End If
        End If
    End If
    '==============================================
    
    
    webbState(tagIndex).Progress = Format(LTrim$(Str$(100 * (tDiv))), "#0") + "%"
End If
If ProgressMax <> 0 And gActiveWebIndex = tagIndex Then
    gMainForm.ChangeStatusText webbState(tagIndex).Progress, 1
End If
End Sub
Private Sub webme_StatusTextChange(ByVal Text As String)
'If tagIndex = 0 Or CanNotShow Then Exit Sub
If tagIndex = 0 Then Exit Sub
webbState(tagIndex).StatusText = Text
If tagIndex = gActiveWebIndex Then    'gMainForm.stabMe.Panels(1).Text = Text
    'SendMessage gMainForm.stabMe.Hwnd, SB_SETTEXTA, 0, ByVal Text
    gMainForm.ChangeStatusText Text
End If
End Sub
Private Sub webme_TitleChange(ByVal Text As String)
On Error GoTo due:
'If tagIndex = 0 Or isUnloading Or CanNotShow Then Exit Sub
If tagIndex = 0 Or isUnloading Then Exit Sub
Dim nTitle As String
If webMe.LocationURL = "about:blank" Then
    nTitle = "about:blank"
ElseIf Not (webMe.Document Is Nothing) Then
    nTitle = webMe.Document.Title
Else
    nTitle = Text
End If
If Trim(nTitle) = "" Then
    nTitle = mWebUrl
End If
'Dim tmpStr  As String
mWebTitle = nTitle
'tmpStr = StrConv(nTitle, vbFromUnicode)
'If LenB(tmpStr) > 14 Then
'    webbState(tagIndex).webTab.Caption = Replace(StrConv(LeftB$(tmpStr, TabsTitleLength), vbUnicode), Chr(0), "") & ".."
'Else
'    webbState(tagIndex).webTab.Caption = mWebTitle
'End If
'
'webbState(tagIndex).webTab.TipText = mWebTitle & vbNewLine & mWebUrl
'Me.Caption = nTitle
Call ChangeTabTitle
Exit Sub
due:
ErrorLog.AddLog "webme_TitleChange" & Chr(9) & Err.Description
End Sub
Private Sub webMe_WindowClosing(ByVal IsChildWindow As Boolean, Cancel As Boolean)
Cancel = True
Call gMainForm.UnloadBrowser(ByVal tagIndex)
End Sub
''=========================================
''找到ms webbrwoser control的hwnd
'Private Function SeekWindow(ByVal hOwner As Long) As Long
'Dim tHwnd As Long
'Dim tCN As String
'Dim tFC As Long
'Do
'    tCN = Space(255)
'    tHwnd = FindWindowEx(hOwner, tHwnd, vbNullString, vbNullString)
'    If tHwnd <> 0 Then
'        GetClassName tHwnd, tCN, 255
'        If Trim(Replace(tCN, Chr(0), " ")) = "Internet Explorer_Server" Then
'            SeekWindow = tHwnd
'            Exit Function
'        End If
'        tFC = SeekWindow(tHwnd)
'        If tFC <> 0 Then
'            SeekWindow = tFC
'            Exit Function
'        End If
'    End If
'Loop Until tHwnd = 0
'
'End Function
''========================================
Public Sub OrgWeb()
If mHWeb <> 0 Then
    MoveWindow mHWeb, 0, 0, widthPixel, heightPixel, True
End If
End Sub
Public Sub BackAndForwardState()
On Error Resume Next
If gActiveWebIndex = tagIndex Then
    gMainForm.m_cTbrMain.EnableButton TbrID_Main_Back, mCanBack
    gMainForm.m_cTbrMain.EnableButton TbrID_Main_Forward, mCanForward
'    gMainForm.tlbMe.Buttons(TbrK_Main_Back).Enabled = mCanBack
'    gMainForm.tlbMe.Buttons(TbrK_Main_Forward).Enabled = mCanForward
    
End If
End Sub
Public Sub FormActive()
If isExit Then Exit Sub
Dim preIndex As String
Dim i As Long
Dim tRc As RECT, tRc2 As RECT, tRc3 As RECT
Dim tpt As POINTAPI
'Debug.Print "form active ", tagIndex
With gMainForm
    If mPvnPop > 0 Then
        .SetTbrBtnState_AutoPvntPop 1 'tbrPressed
    Else
        .SetTbrBtnState_AutoPvntPop 0 ' tbrUnpressed
    End If
    
    Call .m_cTbrSmall.CheckButton(TbrID_Small_LockNew, (IsAllOpenNew = 1))
        
    .CheckTab webbState(tagIndex).TabBtn.Index
    
    .ChangeStatusText webbState(tagIndex).StatusText
    .ChangeStatusText webbState(tagIndex).Progress, 1
    .LocationURLText = mWebUrl
    
    
    preIndex = LTrim$(Str$(tagIndex))
    
    
    '改变标题
    .ChangeCaption mWebTitle
    
    If Me.WindowState = 2 Then
        
        GetClientRect .hMDIClient, tRc
        GetWindowRect Me.hWnd, tRc2
        GetClientRect Me.hWnd, tRc3
        tpt.x = tRc2.Left: tpt.y = tRc2.Top
        ScreenToClient .hMDIClient, tpt
        MoveWindow Me.hWnd, tpt.x, tpt.y, _
            (tRc.Right - tRc.Left) + (tRc2.Right - tRc2.Left) - (tRc3.Right - tRc3.Left), _
            (tRc.Bottom - tRc.Top) + (tRc2.Bottom - tRc2.Top) - (tRc3.Bottom - tRc3.Top), 1
    End If
End With
gActiveWebIndex = tagIndex
Call BackAndForwardState
Call ActiveMe(1)
'================  progress icon   ================
If tagIndex > 0 Then
    If mPreProgressIcon = 4 Then
        'Set webbState(tagIndex).webTab.PictureIN = Nothing
        If Not webbState(tagIndex).TabBtn Is Nothing Then
            Set webbState(tagIndex).TabBtn.ImageNormal = Nothing
            mPreProgressIcon = -1
        End If
    End If
End If
'=================================================
End Sub
Public Sub callGo(ByVal Length As Integer)
On Error GoTo due
Select Case Length
    Case -1
        If mCanBack Then webMe.GoBack
    Case 1
        If mCanForward Then webMe.GoForward
End Select
Exit Sub
due:
    ErrorLog.AddLog Err.Description
End Sub
'不显示漂浮物
Public Sub NoShowFloat()
On Error Resume Next
'Call EnumFrame(webMe.Document.parentwindow, "NoShowFloat2")
Dim i&, tWb As Object, tObj As Object
Dim tWbs As Collection
Set tWbs = New Collection
tWbs.Add webMe
Call EnumFrames(webMe, tWbs)
For Each tWb In tWbs
    Set tObj = Nothing
    Set tObj = tWb.Document
    If Not tObj Is Nothing Then
        Call NoShowFloat2(tObj)
    End If
Next tWb
'For i = 1 To mWebObjCnt
'    If Not mWebObjects(i).IsEmpty Then
'        Set tObj = Nothing
'        Set tObj = mWebObjects(i).WebObject.Document
'        If Not tObj Is Nothing Then
'            Call NoShowFloat2(tObj)
'        End If
'    End If
'Next i
End Sub
Public Sub NoShowFloat2(nDoc As Object)
On Error GoTo due
Dim i&, aLeng&
Dim tObj As Object
Dim tTagName$
If Not nDoc Is Nothing Then
    aLeng = nDoc.All.Length
    For i = aLeng - 1 To 0 Step -1
        Set tObj = nDoc.All(i)
        tTagName = LCase(tObj.tagName)
        Select Case tTagName
            Case "div", "span"
                If LCase(tObj.Style.position) = "absolute" Then
                    tObj.Style.display = "none"
                    'tObj.Style.visibility = "hidden"
                    tObj.innerHTML = ""
                    'tObj.outerHTML = ""
                End If
        End Select
    Next i
End If
Exit Sub
due:
    ErrorLog.AddLog "NoShowFloat2" & Chr(9) & Err.Description
End Sub
'不显示Object
Public Sub NoShowObject()
On Error Resume Next
'Call EnumFrame(webMe.Document.parentwindow, "NoShowObject2")
Dim i&, tObj As Object, tWb As Object
Dim tWbs As Collection
Set tWbs = New Collection
tWbs.Add webMe
Call EnumFrames(webMe, tWbs)
For Each tWb In tWbs
    Set tObj = Nothing
    Set tObj = tWb.Document
    If Not tObj Is Nothing Then
        Call NoShowObject2(tObj)
    End If
Next tWb
'For i = 1 To mWebObjCnt
'    If Not mWebObjects(i).IsEmpty Then
'        Set tObj = Nothing
'        Set tObj = mWebObjects(i).WebObject.Document
'        If Not tObj Is Nothing Then
'            Call NoShowObject2(tObj)
'        End If
'    End If
'Next i
'Exit Sub
'due:
'    Debug.Print Err.Description
End Sub
Public Sub NoShowObject2(nDoc As Object)
On Error GoTo due
Dim i&, aLeng&
Dim tObj As Object
Dim tTagName$
If Not nDoc Is Nothing Then
    aLeng = nDoc.All.Length
    For i = aLeng - 1 To 0 Step -1
        Set tObj = nDoc.All(i)
        tTagName = LCase(tObj.tagName)
        Select Case tTagName
            Case "object"
                'tObj.Style.display = "none"
                tObj.outerHTML = ""
            Case "embed"
                If LCase(Right(tObj.src, 4)) = ".swf" Then
                    'tObj.Style.display = "none"
                    tObj.outerHTML = ""
                End If
        End Select
    Next i
End If
Exit Sub
due:
    ErrorLog.AddLog "NoShowObject2" & Chr(9) & Err.Description
End Sub
Public Sub ClearMouseLimit()
Attribute ClearMouseLimit.VB_Description = "清除右键限制"
On Error Resume Next
Dim i&, tObj As MSHTML.HTMLDocument
Dim tWb As Object, tWbs As Collection
Set tWbs = New Collection
tWbs.Add webMe
Call EnumFrames(webMe, tWbs)
For Each tWb In tWbs
    Set tObj = Nothing
    Set tObj = tWb.Document
    If Not tObj Is Nothing Then
        With tObj
            .onmousedown = ""
            .onmouseup = ""
            .oncontextmenu = ""
            .onselectstart = ""
            .body.onselectstart = ""
            .body.oncontextmenu = ""
            .body.onmousedown = ""
            .body.onmouseup = ""
            .body.ondragstart = ""
            
        End With
    End If
Next tWb
'For i = 1 To mWebObjCnt
'    If Not mWebObjects(i).IsEmpty Then
'        Set tObj = Nothing
'        Set tObj = mWebObjects(i).WebObject.Document
'        If Not tObj Is Nothing Then
'            With tObj
'                .onmousedown = ""
'                .onmouseup = ""
'                .oncontextmenu = ""
'                .onselectstart = ""
'                .body.onselectstart = ""
'                .body.oncontextmenu = ""
'                .body.onmousedown = ""
'                .body.onmouseup = ""
'                '.body.onscroll = ""
'            End With
'        End If
'    End If
'Next i
End Sub
Public Sub RefreshWeb()
webMe.Refresh2 3
End Sub
'"newwindow"后,新窗口需要被调用这个
Public Function IniNewWeb(nAutoCanNew As Boolean, nPreIndex As Long, lptPage As Long) As Object
tagIndex = -1
'CanNotShow = True
mAutoCanNew = nAutoCanNew
mPreIndex = nPreIndex
Set IniNewWeb = webMe '.object
Call CopyPageProperty(lptPage)
mIsSingleWindow = False
Call gMainForm.NewWebbrowser(, Me, , , webbState(mPreIndex).TabBtn.Index + 1)
End Function
'继承属性
Private Sub CopyPageProperty(lptPage As Long)
On Error Resume Next
Dim tProperty As mTypPageProperty
Dim tDlctl As DownloadCtrlFlags
CopyMemory ByVal VarPtr(tProperty), ByVal lptPage, Len(tProperty)
With tProperty
    mPvnPop = .PvnPop
    mDownloadCtrl = .DLCtrl
    mDL_Image = ((.DLCtrl And DLCTL_DLIMAGES) = DLCTL_DLIMAGES)
    mDL_BgSound = ((.DLCtrl And DLCTL_BGSOUNDS) = DLCTL_BGSOUNDS)
    mDL_Video = ((.DLCtrl And DLCTL_VIDEOS) = DLCTL_VIDEOS)
    mDL_Script = Not ((.DLCtrl And DLCTL_NO_SCRIPTS) = DLCTL_NO_SCRIPTS)
    mDL_ActiveX = Not ((.DLCtrl And DLCTL_NO_RUNACTIVEXCTLS) = DLCTL_NO_RUNACTIVEXCTLS)
    mDL_JavaApplet = Not ((.DLCtrl And DLCTL_NO_JAVA) = DLCTL_NO_JAVA)
    mDl_DlActiveX = Not ((.DLCtrl And DLCTL_NO_DLACTIVEXCTLS) = DLCTL_NO_DLACTIVEXCTLS)
    
    vCWebMe.DownloadCtrl = .DLCtrl
    
    mPreIndex = .ParentIndex
    mPreUrl = webbState(mPreIndex).webForm.GetWebUrl
End With
End Sub
Public Sub AddToUrlFilter()
UrlFilterCount = UrlFilterCount + 1
ReDim Preserve UrlFilter(0 To UrlFilterCount)
UrlFilter(UrlFilterCount) = LCase(webMe.LocationURL)
End Sub
'Private Function MatchUrl(nFilterUrl As String, nUrl As String) As Boolean
'Dim tFUrlArr() As String
'Dim i&, ub&, pos1&
'Dim rtn As Boolean
'
'tFUrlArr = Split(nFilterUrl, "*")
'ub = UBound(tFUrlArr)
'pos1 = 1
'rtn = True
'For i = 0 To ub
'    If tFUrlArr(i) <> "" Then
'        pos1 = InStr(pos1, nUrl, tFUrlArr(i), vbTextCompare)
'        If pos1 > 0 Then
'            Select Case i
'                Case 0
'                    If pos1 <> 1 Then
'                        rtn = False
'                        Exit For
'                    End If
'                Case ub
'                    If pos1 + Len(tFUrlArr(i)) - 1 <> Len(nUrl) Then
'                        rtn = False
'                        Exit For
'                    End If
'            End Select
'            pos1 = pos1 + Len(tFUrlArr(i))
'        Else
'            rtn = False
'            Exit For
'        End If
'    End If
'Next i
'
'MatchUrl = rtn
'End Function
Public Property Get hWeb() As Long
hWeb = mHWeb
End Property
'返回点所在的Frame
Public Function FindFrameFromPoint(x As Long, y As Long) As Object
On Error GoTo due
Dim i&
Dim nPt As POINTAPI
Dim rtn As Object, tDoc As Object
Dim tWbs As Collection, tWbsCnt&
nPt.x = x: nPt.y = y
Set rtn = Nothing
Set tWbs = New Collection
tWbs.Add webMe
Call EnumFrames(webMe, tWbs)
tWbsCnt = tWbs.Count
For i = tWbsCnt To 1 Step -1
    Set tDoc = tWbs(i).Document
    If Not tDoc Is Nothing Then
        If FrameInPoint(tDoc, nPt) Then
            Set rtn = tDoc.parentWindow
            Exit For
        End If
    End If
Next i
Set FindFrameFromPoint = rtn
Exit Function
due:
    ErrorLog.AddLog "FindFrameFromPoint" & vbTab & Err.Description '& vbTab & str(mWebObjCnt)
    Resume Next
End Function
'Public Function FindFrameFromPoint2(x As Long, y As Long) As Object
'On Error GoTo due
'Dim i&
'Dim nPt As POINTAPI
'Dim rtn As Object, tDoc As Object
'nPt.x = x: nPt.y = y
'Set rtn = Nothing
'For i = mWebObjCnt To 1 Step -1
'    Set tDoc = Nothing
'    Set tDoc = mWebObjects(i).WebObject.Document
'    If Not tDoc Is Nothing Then
'        If FrameInPoint(tDoc, nPt) Then
'            Set rtn = mWebObjects(i).WebObject.Document.parentWindow
'            Exit For
'        End If
'    End If
'Next i
'Set FindFrameFromPoint2 = rtn
'Exit Function
'due:
'    ErrorLog.AddLog "FindFrameFromPoint" & vbTab & Err.Description '& vbTab & str(mWebObjCnt)
'    Resume Next
'End Function
'点是否在Frame中
Private Function FrameInPoint(nDoc As Object, nPt As POINTAPI) As Boolean
On Error Resume Next
Dim tRc As RECT
Dim rtn As Boolean
rtn = False
tRc.Top = nDoc.parentWindow.screenTop
tRc.Left = nDoc.parentWindow.screenLeft
tRc.Right = tRc.Left + nDoc.body.clientWidth
tRc.Bottom = tRc.Top + nDoc.body.clientHeight
If PtInRect(tRc, nPt.x, nPt.y) Then
    rtn = True
End If
FrameInPoint = rtn
End Function
'Private Function EnumFrame(nWindow As Object, nFunctionName As String) As Boolean
'On Error GoTo due
'
'Dim i&
'Dim frameCnt&
'Dim tWin As Object
'frameCnt = nWindow.Frames.Length
'For i = 0 To frameCnt - 1
'    Set tWin = Nothing
'    Set tWin = nWindow.Frames(i)
'    If Not tWin Is Nothing Then
'        Call EnumFrame(tWin, nFunctionName)
'    End If
'Next i
'
'CallByName Me, nFunctionName, VbMethod, nWindow.Document
'Exit Function
'
'due:
'    ErrorLog.AddLog "EnumFrame" & Chr(9) & Err.Description
'    Resume Next
'End Function
'Private Sub SetWebEvent()
'On Error Resume Next
'If isUnloading Then Exit Sub
'Dim i&
'Dim tDoc As Object, tDrag As cActiveWebEvent
'Dim twb As Object, tWbs As Collection
'Set tWbs = New Collection
'tWbs.Add webMe
'Call EnumFrames(webMe, tWbs)
'For Each twb In tWbs
'    Set tDoc = Nothing
'    Set tDoc = twb.Document
'    If Not tDoc Is Nothing Then
'        Set tDrag = New cActiveWebEvent
'        tDrag.ParentForm = Me
'        tDrag.pDisp = twb
'        tDoc.ondragstart = tDrag
'    End If
'Next twb
'For i = mWebObjCnt To 1 Step -1
'    If Not mWebObjects(i).IsEmpty Then
'        Set tDoc = Nothing
'        Set tDoc = mWebObjects(i).WebObject.Document
'        If Not tDoc Is Nothing Then
'            Set tDrag = New cActiveWebEvent
'            tDrag.pDisp = mWebObjects(i).WebObject
'            tDrag.ParentForm = Me
'            tDoc.ondragstart = tDrag
'        Else
'             mWebObjects(i).IsEmpty = True
'             Set mWebObjects(i).WebObject = Nothing
'        End If
'    End If
'Next i
'End Sub
'Private Function GetNextTab(nIndex As Long) As Long
'Dim i&
'Dim tOrder&, rtn&
'tOrder = webbState(nIndex).tabOrder
'rtn = 0
'For i = 1 To browserCount
'    If webbState(i).isLoaded Then
'        If webbState(i).tabOrder = tOrder + 1 Then
'            rtn = i
'            Exit For
'        End If
'    End If
'Next i
'GetNextTab = rtn
'End Function
Public Function GetWebUrl() As String
GetWebUrl = mWebUrl
End Function
Public Function GetWebTitle() As String
GetWebTitle = mWebTitle
End Function
'使wbb失去输入焦点
Public Sub Release()
Call vCWebMe.Release
End Sub
Private Sub IniVar()
NoActive = False
mSetWebWidth = -1
mSetWebHeight = -1
IsAllOpenNew = 0 ' gIsAllOpenNew
mIsImage = False
mDL_BgSound = gDL_BgSound ' True
mDL_Image = gDL_Image 'True
mDL_Script = gDL_Script 'True
mDL_Video = gDL_Video 'True
mDL_ActiveX = gDL_ActiveX ' True
mDL_JavaApplet = gDL_JavaApplet 'True
mDl_DlActiveX = gDl_DlActiveX
newInSelfScript = False
End Sub
'初始化下载控制,获得mDownloadControl
Private Sub IniDownloadControl()
mDownloadCtrl = DLCTL_Default 'Or DLCTL_NO_DLACTIVEXCTLS  'Or DLCTL_SILENT
'不下载ActiveX
If mDl_DlActiveX Then
Else
    mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_DLACTIVEXCTLS
End If
If mDL_Image Then
Else
    mDownloadCtrl = mDownloadCtrl Xor DLCTL_DLIMAGES
End If
If mDL_BgSound Then
Else
    mDownloadCtrl = mDownloadCtrl Xor DLCTL_BGSOUNDS
End If
If mDL_Video Then
Else
    mDownloadCtrl = mDownloadCtrl Xor DLCTL_VIDEOS
End If
If Not mDL_Script Then
    mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_SCRIPTS
Else
End If
If Not mDL_ActiveX Then
    mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_RUNACTIVEXCTLS
Else
End If
If Not mDL_JavaApplet Then
    mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_JAVA
Else
End If
End Sub
'==================================================
'======== 下载控制, 允许下载的属性,如图片 ===========
'图片
Public Property Get DL_Image() As Boolean
DL_Image = mDL_Image
End Property
Public Property Let DL_Image(ByVal vNewValue As Boolean)
mDL_Image = vNewValue
Call IniDownloadControl
vCWebMe.DownloadCtrl = mDownloadCtrl
webMe.Refresh2 1
End Property
'背景音乐
Public Property Get DL_BgSound() As Boolean
DL_BgSound = mDL_BgSound
End Property
Public Property Let DL_BgSound(ByVal vNewValue As Boolean)
mDL_BgSound = vNewValue
Call IniDownloadControl
vCWebMe.DownloadCtrl = mDownloadCtrl
webMe.Refresh2 1
End Property
'视频
Public Property Get DL_Video() As Boolean
DL_Video = mDL_Video
End Property
Public Property Let DL_Video(ByVal vNewValue As Boolean)
mDL_Video = vNewValue
Call IniDownloadControl
vCWebMe.DownloadCtrl = mDownloadCtrl
webMe.Refresh2 1
End Property
'脚本
Public Property Get DL_Script() As Boolean
DL_Script = mDL_Script
End Property
Public Property Let DL_Script(ByVal vNewValue As Boolean)
mDL_Script = vNewValue
Call IniDownloadControl
vCWebMe.DownloadCtrl = mDownloadCtrl
webMe.Refresh2 1
End Property
'运行ActiveX Control
Public Property Get DL_ActiveX() As Boolean
DL_ActiveX = mDL_ActiveX
End Property
Public Property Let DL_ActiveX(ByVal vNewValue As Boolean)
mDL_ActiveX = vNewValue
Call IniDownloadControl
vCWebMe.DownloadCtrl = mDownloadCtrl
webMe.Refresh2 1
End Property
'运行Java Applet
Public Property Get DL_JavaApplet() As Boolean
DL_JavaApplet = mDL_JavaApplet
End Property
Public Property Let DL_JavaApplet(ByVal vNewValue As Boolean)
mDL_JavaApplet = vNewValue
Call IniDownloadControl
vCWebMe.DownloadCtrl = mDownloadCtrl
webMe.Refresh2 1
End Property
'下载ActiveX
Public Property Get Dl_DlActiveX() As Boolean
Dl_DlActiveX = mDl_DlActiveX
End Property
Public Property Let Dl_DlActiveX(ByVal vNewValue As Boolean)
mDl_DlActiveX = vNewValue
Call IniDownloadControl
vCWebMe.DownloadCtrl = mDownloadCtrl
webMe.Refresh2 1
End Property
'统一设置
Public Sub Dl_EnableAll(nAll As Boolean)
mDL_BgSound = nAll
mDL_Image = nAll
mDL_Script = nAll
mDL_Video = nAll
mDL_ActiveX = nAll
mDL_JavaApplet = nAll
mDl_DlActiveX = nAll
Call IniDownloadControl
'mDownloadCtrl = tDlctl
vCWebMe.DownloadCtrl = mDownloadCtrl
webMe.Refresh2 1
End Sub
'===============================================
'判断url是否图片
Private Function UrlIsImage(ByVal nUrl As String) As Boolean
Dim tPos&, tExtName$
Dim rtn As Boolean
rtn = False
tPos = InStrRev(nUrl, ".")
If tPos > 0 Then
    tExtName = LCase(Mid$(nUrl, tPos + 1))
    Select Case tExtName
        Case "jpg", "jpeg", "gif", "png", "bmp"
            rtn = True
        Case Else
            rtn = False
    End Select
End If
UrlIsImage = rtn
End Function
'判断页面规则
Private Function GetPageRuleIndex(nUrl As String, Optional nAll As Boolean = True) As Long
Dim i&, j&
nUrl = LCase(nUrl)
If nAll Then
    For i = 1 To PageRuleCnt
        With PageRule(i)
            If .Enabled = 1 Then
                For j = 0 To .UrlCnt - 1
                    If MatchUrl(.Urls(j), nUrl) Then
                        GetPageRuleIndex = i
                        Exit Function
                    End If
                Next j
            End If
        End With
    Next i
    GetPageRuleIndex = -1
Else
    For i = 1 To PageRuleCnt
        With PageRule(i)
            If .Enabled = 1 Then
                If .Type = 1 Or .ForceChange Then
                    For j = 0 To .UrlCnt - 1
                        If MatchUrl(.Urls(j), nUrl) Then
                            GetPageRuleIndex = i
                            Exit Function
                        End If
                    Next j
                End If
            End If
        End With
    Next i
    GetPageRuleIndex = -1
End If
End Function
'实施"页面规则",返回值是.Type值,-1则什么都没有执行
'nTypeMask:只检查.Type=nTypeMask的项,<0时,检查所有项
Private Function DoPageRule(ByVal nUrl As String, _
        Optional objIsMe As Boolean = True, _
        Optional nTypeMask As Long = -1) As Long
Dim tIndex As Long
Dim rtn As Long
rtn = -1
If gEnablePageRule = 1 Then
    If mFirstNav Then
        tIndex = GetPageRuleIndex(nUrl)
    Else
        tIndex = GetPageRuleIndex(nUrl, False)
    End If
    If tIndex <> -1 Then
        With PageRule(tIndex)
            If nTypeMask < 0 Or nTypeMask = .Type Then
                Select Case .Type
                    Case 0
                        If (mIsSingleWindow Or .ForceChange) And objIsMe Then
                            mDL_BgSound = .DL_BgSound ' True
                            mDL_Image = .DL_Image 'True
                            mDL_Script = .DL_Script 'True
                            mDL_Video = .DL_Video 'True
                            mDL_ActiveX = .DL_ActiveX ' True
                            mDL_JavaApplet = .DL_JavaApplet 'True
                            mPvnPop = .AutoPreventPop
                            If .AllwaysOpenNew Then
                                IsAllOpenNew = 1
                            Else
                                IsAllOpenNew = 0
                            End If
                            Call IniDownloadControl
                            vCWebMe.DownloadCtrl = mDownloadCtrl
                            
                            If gActiveWebIndex = tagIndex Then
                                If mPvnPop > 0 Then
                                    gMainForm.SetTbrBtnState_AutoPvntPop 1 ' tbrPressed
                                Else
                                    gMainForm.SetTbrBtnState_AutoPvntPop 0 'tbrUnpressed
                                End If
                                
'                                If IsAllOpenNew = 1 Then
'                                    gMainForm.tlbOther.Buttons(TbrK_Small_LockNew).Value = tbrPressed
'                                Else
'                                    gMainForm.tlbOther.Buttons(TbrK_Small_LockNew).Value = tbrUnpressed
'                                End If
                                Call gMainForm.m_cTbrSmall.CheckButton(TbrID_Small_LockNew, (IsAllOpenNew = 1))
                            End If
                            
                            
                            rtn = 0
                        Else
                            rtn = -1
                        End If
                    Case 1
                        ShellExecute 0&, "open", .OutExePath, _
                            Replace(.OutExeParam, "%url%", nUrl), .OutExePath, SW_SHOW
                        rtn = 1
                End Select
            End If
        End With
        
    End If
End If
DoPageRule = rtn
End Function
Public Sub Navigate(url As String, Optional nExe As Boolean = True)
Dim doRtn&
If Not webMe Is Nothing Then
    mIsDoPageRule = True
    
    If nExe Then
        doRtn = DoPageRule(url)
    Else
        doRtn = DoPageRule(url, , 0)
    End If
    'CanNotShow = False
    Select Case doRtn
        Case 1
            'Call gMainForm.UnloadBrowser(ByVal tagIndex)
        Case Else
            webMe.Navigate2 url
    End Select
End If
End Sub
''用于新键页面,检查是否应该显示
''true:链接建立,不需要关闭,false:需要关闭
'Public Function Navigate2(Url As String) As Boolean
'Dim doRtn&
'Dim rtn As Boolean
'rtn = False
'CanNotShow = True
'If Not webMe Is Nothing Then
'    mIsDoPageRule = True
'
'    doRtn = DoPageRule(Url)
'    Select Case doRtn
'        Case 1
'            rtn = False
'            CanNotShow = True
'            'Call gMainForm.UnloadBrowser(ByVal tagIndex)
'        Case Else
'            rtn = True
'            CanNotShow = False
'            'webMe.Navigate2 Url
'    End Select
'End If
'Navigate2 = rtn
'End Function
'获得可以前进后退的步数
'Private Function GetStep(Flags As TLENUMF) As Long
'Dim mEnum As olelib.IEnumTravelLogEntry
'Dim Entry As olelib.ITravelLogEntry
'Dim fetched As ULONG
'Dim stepcnt&
'
'stepcnt = 0
'If Not Stg Is Nothing Then
'    Call Stg.EnumEntries(Flags, mEnum)
'    If Not mEnum Is Nothing Then
'        Call mEnum.Next(1, Entry, fetched)
'        stepcnt = 0
'        While fetched = 1
'            stepcnt = stepcnt + 1
'            Call mEnum.Next(1, Entry, fetched)
'        Wend
'    End If
'End If
'GetStep = stepcnt
'End Function
'获得ITravelLogStg
Public Function LogConnect() As Boolean
On Error Resume Next
Dim isp As olelib.IServiceProvider
Dim tUn As olelib.IUnknown
Set tUn = webMe.Application
Call tUn.QueryInterface(IID_IServiceProvider, isp)
If Not isp Is Nothing Then
    Call isp.QueryService(SID_STravelLogCursor, IID_ITravelLogStg, Stg)
End If
End Function
Public Sub WebGo(nStep As Long)
On Error Resume Next
Dim i&
If nStep > 0 Then
    For i = 1 To nStep
        webMe.GoForward
    Next i
ElseIf nStep < 0 Then
    For i = 1 To -nStep
        webMe.GoBack
    Next i
End If
End Sub
'加载前进后退按钮下拉菜单
Public Sub SetHistoryButton(flags As TLENUMF, vPMnu As cPopMenu) ' Button As MSComctlLib.Button)
'Dim tmnu As MSComctlLib.ButtonMenu
Dim mEnum As olelib.IEnumTravelLogEntry
Dim Entry As olelib.ITravelLogEntry
Dim fetched As ULONG
Dim stepcnt&
Dim tPtrTitle&, tTitle$
Dim tPtrUrl& ', tUrl$
'Button.ButtonMenus.Clear
vPMnu.ClearItems
stepcnt = 0
If Not Stg Is Nothing Then
    Call Stg.EnumEntries(flags, mEnum)
    If Not mEnum Is Nothing Then
        Call mEnum.Next(1, Entry, fetched)
        stepcnt = 0
        While fetched = 1
            stepcnt = stepcnt + 1
            If stepcnt <= 10 Then
                Entry.GetTitle tPtrTitle
                
                tTitle = Trim$(SysAllocString(tPtrTitle))
                Call CoTaskMemFree(tPtrTitle)
                If tTitle = "" Then
                    Entry.GetUrl tPtrUrl
                    tTitle = Trim$(SysAllocString(tPtrUrl))
                    Call CoTaskMemFree(tPtrUrl)
                End If
                'Button.ButtonMenus.Add , , tTitle
                vPMnu.Add tTitle, , stepcnt
                Call mEnum.Next(1, Entry, fetched)
            Else
                fetched = 0
                vPMnu.Add vbNullString, pmsSeparator
                vPMnu.Add "More", pmsString Or pmsDisabled
'                Button.ButtonMenus.Add , , "-"
'                Set tmnu = Button.ButtonMenus.Add(, , "More")
'                tmnu.Enabled = False
            End If
        Wend
    End If
End If
End Sub
'Public Sub SetHistoryButton(Flags As TLENUMF, Button As MSComctlLib.Button)
'If Stg Is Nothing Then Exit Sub
'On Error Resume Next
'Dim tcnt As Long
'Dim backStep As Long
'Dim i&
'Dim tmnu As MSComctlLib.ButtonMenu
'Dim tStr$
'tcnt = GetStep(Flags)
'Button.ButtonMenus.Clear
'
'If tcnt > 0 Then
'    If tcnt > 10 Then tcnt = 10
'    If Flags = TLEF_RELATIVE_FORE Then
'        backStep = GetStep(TLEF_RELATIVE_BACK)
'        For i = 1 To tcnt
'            tStr = ""
'            tStr = Titles(backStep + 1 + i)
'            If tStr = "" Then tStr = "Step" & Str(i)
'            Set tmnu = Button.ButtonMenus.Add(, , tStr)
'        Next i
'    ElseIf Flags = TLEF_RELATIVE_BACK Then
'        For i = 1 To tcnt
'            tStr = ""
'            tStr = Titles(tcnt - i + 1)
'            If tStr = "" Then tStr = "Step" & Str(i)
'            Set tmnu = Button.ButtonMenus.Add(, , tStr)
'        Next i
'    End If
'
'    Button.ButtonMenus.Add , , "-"
'    Set tmnu = Button.ButtonMenus.Add(, , "More")
'    tmnu.Enabled = False
'Else
'    Set tmnu = Button.ButtonMenus.Add(, , "(none)")
'    tmnu.Enabled = False
'End If
'
'End Sub
'设置Titles
'Private Sub SetTitles(Title As String)
'Dim backStep&, foreStep&
'Dim totalStep&
'Dim curStep&
'foreStep = preForeStep ' GetStep(TLEF_RELATIVE_FORE)
'If foreStep = 0 Then
'    totalStep = GetStep(TLEF_ABSOLUTE)
'    curStep = GetStep(TLEF_RELATIVE_INCLUDE_CURRENT)
'    Debug.Print preTotalStep
'    If curStep < preStep Then totalStep = totalStep + 1
'    'preStep = curStep
'    If totalStep <> TitleCnt Then
'        TitleCnt = totalStep
'        ReDim Preserve Titles(0 To TitleCnt)
'    End If
'    Titles(TitleCnt) = Title
'End If
'
'End Sub
'保存网页
Public Sub SaveWeb()
webMe.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT
End Sub
'文字大小
Public Sub SetFontSize(nSize As Long)
webMe.ExecWB OLECMDID_ZOOM, OLECMDEXECOPT_DODEFAULT, CLng(nSize)
End Sub
'设置编码
Public Sub SetCharset(vCharset$)
webMe.Document.Charset = vCharset
webMe.Refresh2 2
End Sub
'页面缩放
Public Sub SetPageZoom(nSize As Single)
webMe.Document.body.Style.Zoom = nSize
End Sub
''获得对应的标签
'Private Function GetTabBtn() As ClXButton
'If tagIndex > 0 Then
'    Set GetTabBtn = webbState(tagIndex).webTab
'Else
'    Set GetTabBtn = Nothing
'End If
'End Function
'高亮关键字
Public Sub HightLight(ByVal nStr As String)
On Error GoTo due:
Dim i&, tObj As Object
nStr = Trim(Replace(nStr, vbNewLine, ""))
If nStr = "" Then Exit Sub
Dim tWb As Object
Dim tWbs As Collection
Set tWbs = New Collection
tWbs.Add webMe
Call EnumFrames(webMe, tWbs)
'If gSelfDrag.SelfDraging Then
'    Call HightLight2(nStr, gSelfDrag.pDisp.Document)
'    For Each tWb In tWbs
'        If ObjPtr(tWb.Application) <> ObjPtr(gSelfDrag.pDisp) Then
'    '        Debug.Print "pdisp:"; ObjPtr(tWb.Application), ObjPtr(gSelfDrag.pDisp)
'    '        Debug.Print "typeof enum:"; TypeOf tWb Is SHDocVw.WebBrowser
'            Set tObj = Nothing
'            Set tObj = tWb.Document
'            If Not tObj Is Nothing Then
'                Call HightLight2(nStr, tObj)
'            End If
'        End If
'    Next tWb
'Else
    For Each tWb In tWbs
        Set tObj = Nothing
        Set tObj = tWb.Document
        If Not tObj Is Nothing Then
            Call HightLight2(nStr, tObj)
        End If
    Next tWb
'End If
'For i = 1 To mWebObjCnt
'    If Not mWebObjects(i).IsEmpty Then
'        Set tObj = Nothing
'        Set tObj = mWebObjects(i).WebObject.Document
'        If Not tObj Is Nothing Then
'            Call HightLight2(nStr, tObj)
'        End If
'    End If
'Next i
Exit Sub
due:
    ErrorLog.AddLog "HightLinght:" & Err.Description
End Sub
Public Sub HightLight2(nKey$, nDoc As MSHTML.HTMLDocument, Optional beforeTag$ = "", Optional afterTag$ = "")
On Error GoTo due
Dim tBody As MSHTML.HTMLBody
Dim oRange As MSHTML.IHTMLTxtRange
If beforeTag = "" Then
    beforeTag = "<span style='background-color:yellow'>"
End If
If afterTag = "" Then
    afterTag = "</span>"
End If
Set tBody = nDoc.body
If Not tBody Is Nothing Then
    Set oRange = tBody.createTextRange
    If Not oRange Is Nothing Then
        oRange.Collapse
        oRange.Select
        Debug.Print "cretee range"
        While oRange.FindText(nKey)
            Call oRange.pasteHTML(beforeTag & oRange.Text & afterTag)
            Call oRange.MoveStart("character", 1)
        Wend
    End If
End If
Exit Sub
due:
    Debug.Print "hl2 err:"; Err.Description, Err.Number
    Resume Next
End Sub
'查找
Public Sub FindWord(nWord$)
On Error GoTo due
If Trim(nWord) = "" Then Exit Sub
Static tBookMark As String 'As Object
Static tPreWord$
Static tPreWb As SHDocVw.WebBrowser
Dim tWb As Object   'html window
Dim tWbs As Collection
Dim HaveFind As Boolean
HaveFind = False
Set tWbs = New Collection
tWbs.Add webMe
Call EnumFrames(webMe, tWbs)
If nWord <> tPreWord Then
    'Set tBookMark = Nothing
    tBookMark = ""
    Set tPreWb = Nothing 'webMe
    tPreWord = nWord
End If
For Each tWb In tWbs
    If tPreWb Is Nothing Then
        Set tPreWb = tWb
    End If
    
    If tWb Is tPreWb Then
        If FindWord2(nWord, tWb.Document, tBookMark) Then
            HaveFind = True
            Exit For
        Else
            Set tPreWb = Nothing
        End If
    End If
Next tWb
If Not HaveFind Then
    tBookMark = ""
    Set tPreWb = Nothing
    tPreWord = ""
    MsgBox "文档搜索完毕", vbExclamation
End If
Exit Sub
due:
    ErrorLog.AddLog "FindWord:" & Err.Description
End Sub
Private Function FindWord2(nWord$, nDoc As MSHTML.HTMLDocument, nPosBM As String) As Boolean
Dim oRange As MSHTML.IHTMLTxtRange
Set oRange = nDoc.body.createTextRange
'If Not nPosBM Is Nothing Then
If nPosBM <> "" Then
    Call oRange.moveToBookmark(nPosBM)
    Call oRange.MoveStart("character", 1)
End If
If oRange.FindText(nWord) Then
    nPosBM = oRange.getBookmark
    'Call oRange.moveToBookmark(nPosBM)
    Call oRange.Select
    
    FindWord2 = True
Else
    'Set nPosBM = Nothing
    nPosBM = ""
    FindWord2 = False
End If
End Function
'向下上滚动页面
Public Sub ScrollPage(ByVal ScrollDown As Boolean)
Dim tpt As POINTAPI
Dim tWin As Object
Call GetCursorPos(tpt)
Set tWin = FindFrameFromPoint(tpt.x, tpt.y)
If Not tWin Is Nothing Then
    If ScrollDown Then
        tWin.scrollBy 0, tWin.Document.body.clientHeight - 20
    Else
        tWin.scrollBy 0, -tWin.Document.body.clientHeight + 20
    End If
End If
End Sub
'Public Sub HightLight3(nKey As String, nDoc As MSHTML.HTMLDocument)
'On Error Resume Next
'Dim bodyText As String
'Dim tBody As MSHTML.HTMLBody
''Dim tNodeCnt&, i&, tStr$
'Set tBody = nDoc.body
'If Not tBody Is Nothing Then
''    tNodeCnt = tBody.childNodes.Length
''    For i = 0 To tNodeCnt - 1
''        If tBody.childNodes(i).nodeType = 3 Then
''            tStr = tBody.childNodes(i).Data
''            If ReplaceHightLight(nKey, tStr) Then
''                tBody.childNodes(i).Data = tStr
''            End If
''        Else
''            tStr = tBody.childNodes(i).innerHTML
''            If ReplaceHightLight(nKey, tStr) Then
''                tBody.childNodes(i).innerHTML = tStr
''            End If
''        End If
''    Next i
'
'    bodyText = tBody.innerHTML
'
'    If ReplaceHightLight(nKey, bodyText) Then
'        tBody.innerHTML = bodyText
'    End If
'End If
'End Sub
'
'
'
'Private Function ReplaceHightLight(nKey$, nBodyText$) As Boolean
'Dim rtn As Boolean
'Dim i&, j&
'Dim b1&, b2&, a1&, a2&
'
'Dim tPos&, tPos2&
'Dim rlsTxt$
'Dim tLen&
'
'Dim highlightStartTag$, highlightEndTag$, StartTagLen&
'highlightStartTag = "<span style='background-color:yellow'>"
'highlightEndTag = "</span>"
'StartTagLen = Len(highlightStartTag)
'
'rtn = False
'tLen = Len(nKey)
'tPos = InStr(1, nBodyText, nKey)
'While tPos > 0
'    b1 = InStrRev(nBodyText, "<", tPos)
'    b2 = InStrRev(nBodyText, ">", tPos)
'    a1 = InStr(tPos, nBodyText, "<")
'    a2 = InStr(tPos, nBodyText, ">")
'
'    If b1 > b2 And a1 > a2 Then
'    Else
'        If IsScript(b1, nBodyText) Then
'        Else
'            rlsTxt = highlightStartTag & nKey & highlightEndTag
'            nBodyText = Left(nBodyText, tPos - 1) & rlsTxt & Mid(nBodyText, tPos + tLen)
'            tPos = tPos + StartTagLen
'            rtn = True
'        End If
'    End If
'    tPos = InStr(tPos + 1, nBodyText, nKey)
'Wend
'ReplaceHightLight = rtn
'End Function
'
'Private Function IsScript(nPos&, nTxt$) As Boolean
'Dim rtn As Boolean
'Dim tPos&, tPos2
'rtn = False
'If nPos > 0 Then
'    tPos = InStr(nPos, nTxt, " ")
'    tPos2 = InStr(nPos, nTxt, ">")
'    If tPos > 0 Then
'        If tPos < tPos2 Or tPos2 <= 0 Then
'            rtn = (LCase(Mid(nTxt, nPos + 1, tPos - nPos - 1)) = "script")
'        End If
'    End If
'
'    If tPos2 > 0 Then
'        If tPos2 < tPos Or tPos <= 0 Then
'            rtn = (LCase(Mid(nTxt, nPos + 1, tPos2 - nPos - 1)) = "script")
'        End If
'    End If
'End If
'IsScript = rtn
'End Function
Public Sub ActiveMe(fActive As bool)
vCWebMe.ActiveMe fActive
End Sub
''执行脚本
'Public Function RunScript(nScript$, nLanguage$, nSubName$) As Boolean
'On Error GoTo due
'Dim tBody As MSHTML.HTMLBody, tWindow As MSHTML.HTMLWindow2
'Dim tScript$
'If Not webMe.Document Is Nothing Then
'    Set tBody = webMe.Document.body
'    Set tWindow = webMe.Document.parentWindow
'    tScript = "<script DEFER language=" & nLanguage & ">" & vbNewLine & _
'        nScript & vbNewLine & "</script>"
'    tScript = "<div id='l_e_script'><br>" & vbNewLine & tScript & vbNewLine & "</div>"
'
'
'    tBody.insertAdjacentHTML "beforeend", tScript
'    tWindow.execScript nSubName, nLanguage
'    tBody.All("l_e_script").outerHTML = ""
'
'End If
'Exit Function
'
'due:
'    ErrorLog.AddLog "RunScript " & Err.Description
'    Resume Next
'End Function
'#################################
'执行脚本
Public Sub RunScript(nScript$, Optional nLanguage$ = "JScript", Optional nRunType As Long = 0)
On Error GoTo due
Dim tWb As Object, tWbs As Collection
Dim tDoc As Object
Dim tWin As Object
Dim tpt As POINTAPI
'Debug.Print nScript, nLanguage
Select Case nRunType
    Case 1
        Set tWbs = New Collection
        tWbs.Add webMe
        Call EnumFrames(webMe, tWbs)
        For Each tWb In tWbs
            Set tDoc = Nothing
            Set tDoc = tWb.Document
            If Not tDoc Is Nothing Then
                Call RunScript2(nScript, nLanguage, tDoc.parentWindow)
            End If
        Next tWb
    Case 2
        Call GetCursorPos(tpt)
        Set tWin = FindFrameFromPoint(tpt.x, tpt.y)
        If Not tWin Is Nothing Then
            Call RunScript2(nScript, nLanguage, tWin)
        End If
    Case Else
        Call RunScript2(nScript, nLanguage)
End Select
Exit Sub
due:
    ErrorLog.AddLog "RunScript" & Chr(9) & Err.Description
    Resume Next
End Sub
Public Sub RunScript2(nScript$, Optional nLanguage$ = "JScript", Optional nWin As MSHTML.HTMLWindow2)
On Error Resume Next
Dim tDoc As MSHTML.HTMLDocument
If nWin Is Nothing Then
    Set tDoc = webMe.Document
    Set nWin = tDoc.parentWindow
End If
If Not nWin Is Nothing Then
    newInSelfScript = True
    nWin.execScript nScript, nLanguage
    newInSelfScript = False
End If
End Sub
''主要是被鼠标手势调用
'Public Sub RunScriptByIndex(index&)
''If index > 0 And index <= gScriptCnt Then
''    With gScripts(index)
''        If Not .LoadedScript Then
''            Call LoadScriptFile2(gScripts(index))
''        End If
'''        Debug.Print "RunScriptByIndex", index
''        Call RunScript(.Script, .Language, .RunType)
''    End With
''End If
'End Sub
'Public Sub RunScriptFile(nFile$, nLanguage$)
'On Error GoTo due
'Dim tFN&
'Dim tStr$
'tFN = FreeFile
'Open nFile For Binary As tFN
'    tStr = StrConv(InputB(tFN, LOF(tFN)), vbUnicode)
'Close tFN
'Call RunScript2(tStr, nLanguage)
'Exit Sub
'
'due:
'    Reset
'End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetAllDocument
' DateTime  : 2005-7-31 22:50
' Author    : Lingll
' Purpose   : 主要是供插件使用
'---------------------------------------------------------------------------------------
Public Function GetAllDocument() As Collection
Dim tWbs As Collection
Dim tWb As SHDocVw.WebBrowser
Dim colResult As Collection
Set tWbs = New Collection
tWbs.Add webMe
Call EnumFrames(webMe, tWbs)
Set colResult = New Collection
For Each tWb In tWbs
    colResult.Add tWb.Document
Next tWb
Set GetAllDocument = colResult
Set colResult = Nothing
End Function
'枚举页面中所有的frame
Public Sub EnumFrames(ByVal wb As SHDocVw.WebBrowser, wbs As Collection)
Dim pContainer As olelib.IOleContainer
Dim pEnumerator As olelib.IEnumUnknown
Dim pUnk As olelib.IUnknown
Dim pBrowser As SHDocVw.WebBrowser
   Set pContainer = wb.Document
   
   ' Get an enumerator for the frames
   If pContainer.EnumObjects(OLECONTF_EMBEDDINGS, pEnumerator) = 0 Then
      Set pContainer = Nothing
      ' Enumerate and refresh all the frames
      Do While pEnumerator.Next(1, pUnk) = 0
         On Error Resume Next
         
         ' Clear errors
         Err.Clear
         
         ' Get the IWebBrowser2 interface
         Set pBrowser = pUnk
   
         If Err.Number = 0 Then
            'Debug.Print "Frame: " & pBrowser.LocationURL
            wbs.Add pBrowser
            Call EnumFrames(pBrowser, wbs)
         End If
      Loop
      Set pEnumerator = Nothing
   End If
End Sub
'改变me.caption,标签的文字,tiptext
Private Sub ChangeTabTitle()
Attribute ChangeTabTitle.VB_Description = "改变me.caption,标签的文字,tiptext"
'Dim tmpStr  As String
'tmpStr = StrConv(mWebTitle, vbFromUnicode)
'If LenB(tmpStr) > TabsTitleLength + 2 Then
'    webbState(tagIndex).webTab.Caption = StrConv(LeftB$(tmpStr, TabsTitleLength), vbUnicode) & ".."
'Else
'    webbState(tagIndex).webTab.Caption = mWebTitle
'End If
With webbState(tagIndex).TabBtn
    .Caption = Mid2(mWebTitle, , TabsTitleLength, "..")
    .TipTitle = mWebTitle
    .tiptext = mWebUrl
End With
'webbState(tagIndex).webTab.Caption = Mid2(mWebTitle, , TabsTitleLength, "..")
'
'webbState(tagIndex).webTab.TipTitle = mWebTitle
'webbState(tagIndex).webTab.TipText = mWebUrl
Me.Caption = mWebTitle
If gActiveWebIndex = tagIndex Then
    gMainForm.ChangeCaption mWebTitle
End If
End Sub
Private Sub webMe_WindowSetHeight(ByVal height As Long)
Debug.Print "height:"; height
mSetWebHeight = height
End Sub
Private Sub webMe_WindowSetWidth(ByVal width As Long)
Debug.Print "width:"; width
mSetWebWidth = width
End Sub
'判断是否被设置了长宽
Public Function HaveSetRect() As Boolean
HaveSetRect = (mSetWebHeight > 0 And mSetWebWidth > 0)
End Function
'获得窗口宽
Public Function GetSetWinWidth() As Long
Dim wrc As RECT, crc As RECT
GetWindowRect Me.hWnd, wrc
GetClientRect Me.hWnd, crc
GetSetWinWidth = mSetWebWidth + (wrc.Right - wrc.Left) - (crc.Right - crc.Left) + 4
End Function
'获得窗口长
Public Function GetSetWinHeight() As Long
Dim wrc As RECT, crc As RECT
GetWindowRect Me.hWnd, wrc
GetClientRect Me.hWnd, crc
GetSetWinHeight = mSetWebHeight + (wrc.Bottom - wrc.Top) - (crc.Bottom - crc.Top) + 4
End Function
'Private Function GetBorderWidth(nHwnd&, getWidth As Boolean) As Long
'Dim trc As RECT, trc2 As RECT
'GetWindowRect nHwnd, trc
'GetClientRect nHwnd, trc2
'If getWidth Then
'    GetBorderWidth =trc.Right-trc.Left +trc2.
'
'End Function
'设置designMode
Public Sub SetDesignMode(vOn As Boolean)
On Error Resume Next
If vOn Then
    webMe.Document.designMode = "on"
Else
    webMe.Document.designMode = "off"
End If
End Sub

						