作者:欧欧 来源:风者信息科技 发布时间:2022-07-01
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