Dim currIndex As Integer
Dim btnTotal As Integer
Dim textPath As String
Dim buttonRightVal As Integer   '鼠标右击菜单
Dim currTest As Boolean
Dim dragCurrObj As Integer
Dim dragObjX As Integer
Dim dragStartX As Integer
'双击窗体，新建标签
Private Sub Form_DblClick()
    newPath
End Sub
'新窗体转过来的值
Private Sub Form_LinkExecute(CmdStr As String, Cancel As Integer)
    Me.SetFocus
    If CmdStr <> "" Then
        newPath
        myweb(currIndex).Navigate "file:///" & CmdStr
    End If
    Cancel = False
End Sub
'连接语句
Private Sub LinkAndSendMessage(ByVal Msg As String)
    Dim t As Long
    Me.LinkMode = 0
    Me.LinkTopic = ""
    inputText.LinkMode = 0
    inputText.LinkTopic = "欧欧浏览器|ooMain"
    inputText.LinkMode = 2
    inputText.LinkExecute Replace(Msg, Chr(34), "")
    
    t = inputText.LinkTimeout     '--
    inputText.LinkTimeout = 1     '  |______终止DDE通道。当然，也可以用别的方法
    inputText.LinkMode = 0        '  |      这里用的是超时强制终止的方法
    inputText.LinkTimeout = t     '--
    
    End
    Unload Me
End Sub
'窗体加载
Private Sub Form_Load()
     '--------------------------------------------------------防止多个程序同时打开
    '使用打开方式打开的文件
    Me.LinkMode = 1
    Me.LinkTopic = "ooMain"
    If Command <> "" Then
        If App.PrevInstance Then
           LinkAndSendMessage (Command)
        Else
            newPath
            myweb(currIndex).Navigate "file:///" & Replace(Command, Chr(34), "")
        End If
    Else
        If App.PrevInstance Then
            LinkAndSendMessage ("")
        End If
    End If
    '--------------------------------------------------------防止多个程序同时打开结束
    
    dragCurrObj = -1    '当前拖动对象
    currTest = False    '当前是否在测试？
    textPath = App.Path & "\urlText.txt"
    
    Me.OLEDropMode = 1   '允许拖动文件
    
    currIndex = 0
    
    Me.Width = Screen.Width - 200 * 15
    Me.Height = Screen.Height - 100 * 15
    
    prevBtn.Enabled = False
    nextBtn.Enabled = False
    
    
    '加载上一次打开的页面
    If currTest = False Then
        Dim urlStr As String
        urlStr = ""
        If Dir(textPath) <> "" Then
            Open textPath For Input As #1
                urlStr = StrConv(InputB(LOF(1), 1), vbUnicode)
            Close
        End If
        If urlStr = "" Or Len(urlStr)  1 Then
'        Dim a
'        a = MsgBox("需要保存当前打开的所有页面吗？", 4, "保存提醒")
'        MsgBox (a)
'        If a <> 1 Then
'           For i = myweb.LBound To myweb.UBound
'                If IsObjIndex(myweb(i)) And i <> 0 Then
'                    Unload myweb(i)
'                    Unload menuBtn(i)
'                End If
'            Next
'        End If
'
'        saveText    '保存当前所有页面
'    End If
'End Sub
'适应大小
Function resize()
    Dim i As Integer
    If (Me.Width > 204 * 15) Then
         '顶部工具的位置
        goBtn.Left = Me.Width - 80 * 15
        inputText.Width = Me.Width - 204 * 15
        
        'web的位置
        If IsObjIndex(myweb(currIndex)) Then
            myweb(currIndex).Width = Me.Width - 15 * 15
            myweb(currIndex).Height = Me.Height - 106 * 15
            myweb(currIndex).Left = 0
            'myweb(currIndex).Top = 66 * 15
        End If
        '关闭按钮
        closeBtn.Left = Me.Width - closeBtn.Width - 26 * 15
        
        '新增页面按钮
        newPathBtn.Left = Me.Width - closeBtn.Width - 96 * 15
        
        '显示当前页面
        For i = myweb.LBound To myweb.UBound
            If IsObjIndex(myweb(i)) And i <> 0 Then
                If i <> currIndex Then
                    myweb(i).Top = Me.Height
                    menuBtn(i).FontBold = False
                Else
                    myweb(i).Top = 66 * 15
                    menuBtn(i).FontBold = True
                End If
                menuBtn(i).Left = menuBtn(i).Tag * menuBtn(i).Width + 150 + 50
            End If
        Next
        
        setTitle (currIndex)
        setDocumentFocus (currIndex)
        setInputText (currIndex)
    End If
End Function
'拖动打开
Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
    newPath
    myweb(currIndex).Navigate Data.Files(1)
    'MsgBox (getUrlSuffix(Data.Files(1)))
End Sub
'自适应
Private Sub Form_Resize()
   resize
End Sub
'关闭当前页面
Private Sub closeBtn_Click()
    closeCurrWeb
End Sub
'关闭当前页面
Function closeCurrWeb()
    If currIndex <> 0 Then
        '菜单按钮排序
        Dim i As Integer
        For i = menuBtn.LBound To menuBtn.UBound
            If IsObjIndex(menuBtn(i)) And i <> 0 Then
                If menuBtn(i).Tag > menuBtn(currIndex).Tag Then
                    menuBtn(i).Tag = menuBtn(i).Tag - 1
                End If
            End If
        Next
    
        Unload myweb(currIndex)
        Unload menuBtn(currIndex)
        
        '设置当前页面
        Dim maxTag As Integer
        maxTag = -1
        For i = menuBtn.LBound To menuBtn.UBound
            If IsObjIndex(menuBtn(i)) And i <> 0 Then
                If maxTag  0 Then IsObjIndex = False
End Function
'
'---------------------------------------------------------------------------------------------------当前选项右击菜单
'关闭当前页面
Private Sub currSelectClose_Click()
    Dim currIndex_ As Integer
    currIndex_ = currIndex
    currIndex = buttonRightVal
    closeCurrWeb
    If currIndex_ <> buttonRightVal Then
        currIndex = currIndex_
        resize
    End If
End Sub
'刷新当前页面
Private Sub currSelectReload_Click()
    myweb(buttonRightVal).Refresh
End Sub
'保存当前页面
Private Sub currSelectSave_Click()
    myweb(buttonRightVal).ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT
End Sub
'打开主页
Private Sub currSelectHome_Click()
    myweb(buttonRightVal).GoHome
End Sub
'停止加载
Private Sub currSelectStop_Click()
    myweb(buttonRightVal).Stop
End Sub
'
'---------------------------------------------------------------------------------------------------当前选项右击菜单结束
'
'
'---------------------------------------------------------------------------------------------------系统按钮
'
'设为默认浏览器
Private Sub systemDefaultIE_Click()
    Set wsh = CreateObject("WScript.shell")
    wsh.RegWrite "HKEY_CLASSES_ROOT\http\shell\open\command\", (App.Path & "\" & App.EXEName & ".exe"), "REG_SZ"
    wsh.RegWrite "HKEY_CLASSES_ROOT\http\shell\open\ddeexec\Application\", "欧欧浏览器", "REG_SZ"
End Sub
'internet选项
Private Sub systemInternet_Click()
    ret = Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", 5)
End Sub
'新增页面
Private Sub systemNewPath_Click()
newPath
End Sub
'打开主页
Private Sub systemOpenHome_Click()
    newPath
    myweb(myweb.UBound).GoHome
End Sub
'
'---------------------------------------------------------------------------------------------------系统按钮结束
'
'
'停止拖动
Function menuStopDrat()
    If dragCurrObj <> -1 Then
        If Abs(dragStartX - menuBtn(dragCurrObj).Left) >= 30 Then
           '拖动
            '菜单按钮排序
            Dim currTag As Integer
            currTag = menuBtn(dragCurrObj).Tag
            For i = menuBtn.LBound To menuBtn.UBound
                If IsObjIndex(menuBtn(i)) And i <> 0 Then
                    If menuBtn(dragCurrObj).Left > dragStartX Then
                        If menuBtn(i).Tag > menuBtn(dragCurrObj).Tag And menuBtn(i).Left < menuBtn(dragCurrObj).Left Then
                            If currTag < menuBtn(i).Tag Then
                                currTag = menuBtn(i).Tag
                            End If
                            menuBtn(i).Tag = menuBtn(i).Tag - 1
                        End If
                    Else
                        If menuBtn(i).Tag  menuBtn(dragCurrObj).Left Then
                            If currTag > menuBtn(i).Tag Then
                                currTag = menuBtn(i).Tag
                            End If
                            menuBtn(i).Tag = menuBtn(i).Tag + 1
                        End If
                    End If
                End If
            Next
            menuBtn(dragCurrObj).Tag = currTag
        End If
        resize
    End If
    dragCurrObj = -1
End Function
'页面选项右击菜单
Private Sub menuBtn_MouseDown(index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbRightButton Then
        currIndex = index
        resize
        
        buttonRightVal = index
        PopupMenu rightSelect
    Else
        dragCurrObj = index
        dragObjX = X
        For i = menuBtn.LBound To menuBtn.UBound
        If IsObjIndex(menuBtn(i)) Then
            If i = index Then
                menuBtn(i).ZOrder (0)
                dragStartX = menuBtn(i).Left
            Else
                menuBtn(i).ZOrder (1)
            End If
        End If
    Next
    End If
End Sub
'页面切换
Private Sub menuBtn_MouseUp(index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Abs(dragStartX - menuBtn(index).Left) < 30 Then
        '点击
        currIndex = index
        resize
    Else
        menuStopDrat
    End If
    dragCurrObj = -1
End Sub
'拖动控件
Private Sub menuBtn_MouseMove(index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If dragCurrObj <> -1 Then
       menuBtn(dragCurrObj).Left = menuBtn(dragCurrObj).Left + X - dragObjX
    End If
End Sub
'---------------------------------------选项右击菜单结束
'点击访问按钮
Private Sub goBtn_Click()
    myweb(currIndex).Navigate (inputText.Text)
End Sub
'地址框焦点
Private Sub inputText_GotFocus()
    inputText.SelStart = 0
    inputText.SelLength = Len(inputText.Text)
End Sub
'地址框快捷键
Private Sub inputText_KeyPress(KeyAscii As Integer)
    '全选
    If KeyAscii = 1 Then
        inputText.SelStart = 0
        inputText.SelLength = Len(inputText.Text)
        inputText.SetFocus
    End If
    '回车
    If (KeyAscii = 13) Then
        If myweb.Count <= 1 Then
            newPath
        End If
        myweb(currIndex).Navigate (inputText.Text)
    End If
    
    '关闭当前页面
    If (KeyAscii = 23) Then
        closeCurrWeb
    End If
End Sub
'真正获取到地址事件
Private Sub myweb_NavigateComplete2(index As Integer, ByVal pDisp As Object, URL As Variant)
    If index = currIndex Then
        setInputText (index)
    End If
    setTitle (index)
    saveText    '保存当前所有页面
End Sub
'当前web窗体焦点
Private Sub myweb_CommandStateChange(index As Integer, ByVal Command As Long, ByVal Enable As Boolean)
    'myweb(currIndex).Document.parentwindow.scrollby 0, 30  '滚动窗体
    '判断是否可以后退
    If Command = CSC_NAVIGATEBACK Then
        prevBtn.Enabled = Enable
    End If
    '判断是否可以前进
    If Command = CSC_NAVIGATEFORWARD Then
        nextBtn.Enabled = Enable
    End If
    'setInputText (index)
End Sub
'网页开始加载
Private Sub myweb_DownloadBegin(index As Integer)
    myweb(index).Silent = True  '设置不弹出js错误提示
    setTitle (index)
End Sub
'网页加载完毕
Private Sub myweb_DownloadComplete(index As Integer)
    If IsObjIndex(menuBtn(index)) Then
        myweb(index).Silent = True  '设置不弹出js错误提示
    End If
    setTitle (index)
End Sub
'页面全部加载完毕
Private Sub myweb_DocumentComplete(index As Integer, ByVal pDisp As Object, URL As Variant)
    setDocumentFocus (index)
    setTitle (index)
End Sub
'设置页面标题
Function setTitle(index As Integer)
    Dim titleStr As String
    titleStr = ""
    On Error GoTo Errh
        titleStr = Left(myweb(index).Document.Title, 20)
Errh:
    If titleStr = "" Then
        If IsObjIndex(myweb(index)) Then
            titleStr = Left(myweb(index).LocationName, 20)
        End If
    End If
    If titleStr = "" Then
        titleStr = "未标题"
    End If
    If IsObjIndex(myweb(index)) Then
        menuBtn(index).Caption = titleStr
    End If
    If index = currIndex Then
        Me.Caption = titleStr
    End If
End Function
'设置页面焦点
Function setDocumentFocus(index As Integer)
    If currIndex = index Then
        On Error GoTo Errh2
        myweb(index).Document.body.focus
Errh2:
    End If
End Function
'设置inputText的值
Function setInputText(index As Integer)
    Dim urlStr As String
    If currIndex = index Then
         On Error GoTo Errh2
         urlStr = myweb(index).LocationURL
Errh2:
    End If
    inputText.Text = urlStr
End Function
'新窗口事件
Private Sub myweb_NewWindow2(index As Integer, ppDisp As Object, Cancel As Boolean)
    Dim openUrl As String
    openUrl = ""
    
    On Error GoTo Errh
        openUrl = myweb(index).Document.activeElement.href
Errh:
    
    If openUrl = "" Then
        altVal = MsgBox("是否允许弹出页面？", 1, "弹出页面提醒")
        If altVal = 1 Then
            openUrl = "yes"
        End If
    End If
    
    If openUrl <> "" Then
        newPath '新增页面
        Set ppDisp = myweb(myweb.UBound).Object
    Else
        newPath '新增页面
        Set ppDisp = myweb(myweb.UBound).Object
        closeCurrWeb
    End If
End Sub
'新增页面按钮
Private Sub newPathBtn_Click()
    newPath '新增页面
End Sub
'新增页面
Function newPath()
    inputText.Text = ""
    Dim addVal As Integer
    addVal = myweb.UBound + 1
    currIndex = addVal
    '创建web窗体
    Load myweb(addVal)
    myweb(addVal).Visible = True
    '创建标签
    Load menuBtn(addVal)
    menuBtn(addVal).Visible = True
    menuBtn(addVal).Tag = menuBtn.Count - 2
    
    resize
End Function
'前进按钮
Private Sub nextBtn_Click()
    myweb(currIndex).GoForward
End Sub
'后退按钮
Private Sub prevBtn_Click()
    myweb(currIndex).GoBack
End Sub
'保存当前所有页面
Function saveText()
    If currTest = False Then
        '显示当前页面
        Dim urlStr As String
        urlStr = ""
        For i = myweb.LBound To myweb.UBound
            If IsObjIndex(myweb(i)) And i <> 0 Then
                '保存当前页面
                If urlStr = "" Then
                    urlStr = myweb(i).LocationURL
                Else
                    urlStr = urlStr & "|||" & myweb(i).LocationURL
                End If
            End If
        Next
        '保存当前所有页面
        Open textPath For Output As #8
        Print #8, URLEncode(urlStr)
        Close #8
    End If
End Function
'编码函数
Public Function URLEncode(ByRef strURL As String) As String
Dim i As Long
Dim tempStr As String
For i = 1 To Len(strURL)
If Asc(Mid(strURL, i, 1)) = 65 And Asc(Mid(strURL, i, 1)) = 97 And Asc(Mid(strURL, i, 1))  127 Then
URLDecode = URLDecode & Chr(Val("&H" & Mid(strURL, i + 1, 2) & Mid(strURL, i + 4, 2)))
i = i + 5
Else
URLDecode = URLDecode & Chr(Val("&H" & Mid(strURL, i + 1, 2)))
i = i + 2
End If
Else
URLDecode = URLDecode & Mid(strURL, i, 1)
End If
Next
End Function
'获取url后缀
Function getUrlSuffix(urlStr As String)
    urlArr = Split(urlStr, ".")
    getUrlSuffix = urlArr(UBound(urlArr))
End Function