玖叶教程网

大家好，上期的视频可能各位已经看了，感觉代码截图还是有点多，今天我以文章的形式将界面设计及其事件行为代码全部呈现给大家吧！

一、界面设计

(一)前端界面设计

给这个按钮添加代码截图

(二)后台窗体界面设计

1、窗体设计

2、在窗体上添加转到按钮Go

3、在窗体上添加主页按钮Home

4、在窗体上添加后退按钮Back

5、在窗体上添加前进按钮Forward

6、在窗体上添加刷新按钮Refresh

7、在窗体上添加停止按钮Stop

8、在窗体上添加空白页按钮About:Blank

9、在窗体上添加网页html源代码显示按钮WebPagesHtmlSourceCode

10、在窗体上添加图片控件Image1

11、在窗体上添加浏览器控件WebBrowser1

12、在窗体上添加状态栏控件StatusBar1

二、功能代码实现

(一)模块1代码：

'在模块中声明私有变量ActiveTB变量为窗体MSForms中的文本框类型的

Private ActiveTB As MSForms.TextBox

'CreateShortCutMenu过程用来创建标题为"ShortCut"的右键快捷菜单，并添加4个菜单项

Public Sub CreateShortCutMenu()

Dim ShortCutMenu As CommandBar '定义ShortCutMenu快捷菜单变量为CommandBar命令栏类型

Dim ShortCutMenuItem As CommandBarButton '定义ShortCutMenuItem快捷菜单项变量

'为CommandBarButton命令栏按钮类型

Dim sCaption As Variant '定义sCaption菜单项标题变量为Variant可变类型(数组)

Dim iFaceId As Variant '定义iFaceId菜单项皮肤ID变量为Variant可变类型(数组)

Dim sAction As Variant '定义sAction菜单项动作名称变量为Variant可变类型(数组)

Dim i As Integer

'以下是初始化菜单项的属性数组sCaption、iFaceId、sAction

sCaption = Array("剪切(&C)", "复制(&T)", "贴粘(&P)", "删除(&D)")

iFaceId = Array(21, 19, 22, 1786)

sAction = Array("Action_Cut", "Action_Copy", "Action_Paste", "Action_Delete")

On Error Resume Next '遇到错误，则继续唤醒执行下一条语句

Application.CommandBars("ShortCut").Delete

Set ShortCutMenu = Application.CommandBars.Add("ShortCut", msoBarPopup)

With ShortCutMenu '对4个菜项单分别赋予属性：标题、皮肤ID、行为(动作)

For i = 0 To 3

'设置快捷菜单项为控件类Controls的添加Add控件按钮msoControlButton事件

Set ShortCutMenuItem = .Controls.Add(msoControlButton)

With ShortCutMenuItem '4个菜项单分别赋予属性：标题、皮肤ID、行为(动作)

.Caption = sCaption(i)

.FaceId = Val(iFaceId(i))

.OnAction = sAction(i)

End With

Next

End With

End Sub

'ShowPopupMenu过程是根据文本框中字符的选中状态设置右键

'快捷菜单项的Enabled属性后使用ShowPopup方法显示右键快捷菜单

Public Sub ShowPopupMenu(txtCtr As MSForms.TextBox) 'txtCtr为窗体的文本控件类型

Set ActiveTB = txtCtr '用ActiveTB指向文本框对象txtCtr

With Application.CommandBars("ShortCut")

.Controls(1).Enabled = txtCtr.SelLength > 0 '如果当前文本框中已有选中的字符则"剪切"按钮有效

.Controls(2).Enabled = .Controls(1).Enabled '如果当前文本框中已有选中的字符则"复制"按钮有效

.Controls(3).Enabled = txtCtr.CanPaste '如果剪贴板中包含对象支持的数据。则"贴粘"按钮有效

.Controls(4).Enabled = .Controls(1).Enabled '如果当前文本框中已有选中的字符则"删除"按钮有效

.ShowPopup '显示快捷菜单

End With

End Sub

'是快捷菜单中单击"剪切"菜单项所运行的过程。使用Cut 方法将当前选中的文本框中的文本删除并移至剪贴板

Public Sub Action_Cut()

ActiveTB.Cut

End Sub

'是快捷菜单中单击"复制"菜单项所运行的过程。使用Copy方法将文本框选中的文本复制到剪贴板上

Public Sub Action_Copy()

ActiveTB.Copy

End Sub

'是快捷菜单中单击"贴粘"菜单项所运行的过程。使用Paste方法把剪贴板上的内容传送到一个文本框中

Public Sub Action_Paste()

ActiveTB.Paste

End Sub

'是快捷菜单中单击"贴粘"菜单项所运行的过程。使用Replace函数将文本框中选中的文本的文本替换成空字符

Public Sub Action_Delete()

Dim s As String

With ActiveTB

s = .SelText

.Value = Replace(.Value, s, "")

End With

End Sub

'删除创建的右键快捷菜单

Public Sub DeleteShortCutMenu()

On Error Resume Next

Application.CommandBars("ShortCut").Delete

End Sub

(二)窗体代码：

'定义strURL为公有的网址变量用于中间传递网址，s为保存访问当前网页源代码字符串变量

'另外定义firstURL, lastURL, URL_Array(500)是网页首址、尾址，地址数组

Dim strURL, s, firstURL, lastURL, URL_Array(500) As String

Dim clc_URL As New Collection '定义clc_URL为地址集合（具有地址重复的排他性，即不重复）

Dim i As Integer '定义i为地址数组URL_Array( )元素下标，可以在任意过程中使用

'以下是恢复VBA窗体应有的最小化、最大化按钮

Option Explicit

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const GWL_STYLE = (-16)

Private Const WS_THICKFRAME As Long = &H40000 '(恢复大小)

Private Const WS_MINIMIZEBOX As Long = &H20000 '(最小化)

Private Const WS_MAXIMIZEBOX As Long = &H10000 '(最大化)

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const WM_SYSCOMMAND = &H112

Private Const SC_MAXIMIZE = &HF030&

Private Sub UserForm_Initialize()

Call userform1_max_min_Btn_display '重构窗体的最大化最小化按钮显示

WebBrowser1.Silent = True '避免出现脚本错误，设置浏览器控件为安静状态Silent = True

i = 0 '初始化地址数组URL_Array( )下标为0

'TextBox1.SetFocus '窗体初始化时可设地址栏输入框TextBox1为起始输入焦点，即光标初始出现在地址栏输入框TextBox1

End Sub

'窗体尺寸改变事件

Private Sub UserForm_Resize() '文本框、浏览器视图区随窗体变化而变化

TextBox1.Width = UserForm1.Width - TextBox1.Left - 60

GoBtn.Left = TextBox1.Left + TextBox1.Width + 4

If UserForm1.Height - WebBrowser1.Top - 50 < 0 Then '若窗体最小化导致

WebBrowser1.Height = 0 '致UserForm1.Height - WebBrowser1.Top - 50 < 0

'则重置浏览器控件高度WebBrowser1.Height为0

Else '否则按照正常的尺寸跟随改变

WebBrowser1.Width = UserForm1.Width - WebBrowser1.Left - 20

WebBrowser1.Height = UserForm1.Height - WebBrowser1.Top - 50

End If

'构筑图形Image1作为WebBrowser1的边框背景，设置其Left、Top、Width、Height属性跟随WebBrowser1变化

Image1.Left = WebBrowser1.Left - 2

Image1.Top = WebBrowser1.Top - 2

Image1.Width = WebBrowser1.Width + 5

Image1.Height = WebBrowser1.Height + 5

'构筑状态栏StatusBar1，设置其属性，其中Panels(1)是第一个面板

StatusBar1.Top = WebBrowser1.Top + WebBrowser1.Height + 3

StatusBar1.Width = WebBrowser1.Width

StatusBar1.Panels(1).Width = StatusBar1.Width - 2

End Sub

'以下是当TextBox1输入内容完成回车离开后将刚才输入的内容传送到浏览器控件

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

WebBrowser1.Navigate (TextBox1.Text) '浏览器导航网址进入页面

If TextBox1.Text = "" Then

BackBtn.Enabled = False

ForwardBtn.Enabled = False

Else

BackBtn.Enabled = True

ForwardBtn.Enabled = True

End If

s = ""

End Sub

'文本框的右键菜单事件

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

Call CreateShortCutMenu '动态创建快捷菜单

'若点击了鼠标上面的第2个键即右键

If Button = 2 Then ShowPopupMenu ActiveControl '若点击鼠标右键（即第2键），调用过程

'ShowPopupMenu ActiveControl显示弹出的

'快捷菜单，其中ActiveControl为活动控件

End Sub

Private Sub GoBtn_Click() 'Go转向按钮的的转向事件

WebBrowser1.Navigate (TextBox1.Text) '浏览器导航网址进入页面

If TextBox1.Text = "" Then

BackBtn.Enabled = False

ForwardBtn.Enabled = False

Else

BackBtn.Enabled = True

ForwardBtn.Enabled = True

End If

s = ""

End Sub

'页面标题进行动态修改窗体标题过程

Sub Page_Title()

Dim start_pos, end_pos As Integer

Dim title As String

If TextBox1.Value <> "" And TextBox1.Value <> "about:blank" Then '若地址收入栏非空且也不为空白页

s = "" '当点击源码查看按钮WebPagesHtmlSourceCodeBtn时，s源码字符串置空

's获取最新访问的网页的源码（用WebBrowser1.Document.DocumentElement.innerHTML轻易实现）

s = s & WebBrowser1.Document.DocumentElement.innerHTML

s = UCase(s) '将s中的小写字符统统变为大写，这里用了UCase(s)函数

start_pos = Val(InStr(s, "<TITLE>")) + 7

end_pos = Val(InStr(s, "</TITLE>"))

title = Mid(s, start_pos, end_pos - start_pos)

UserForm1.Caption = "WebBrowser-" & title

Else

UserForm1.Caption = "WebBrowser"

End If

End Sub

'当新网页文档内容完全加载完时，调用页面标题进行动态修改窗体标题事件

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)

Call Page_Title '网页文档加载完后调用网页标题去修改窗体标题功能

Call userform1_max_min_Btn_display '恢复最大化、最小化按钮显示

End Sub

'浏览器控件在新导航NavigateComplete2页面完成后触发的事件

Private Sub WebBrowser1_NavigateComplete2(ByVal pDisp As Object, URL As Variant)

'以下是将新页面的网址送达文本框TextBox1

TextBox1.Value = WebBrowser1.LocationURL

'状态栏第一个面板StatusBar1.Panels(1)同步获取网址信息

StatusBar1.Panels(1).Text = WebBrowser1.LocationURL

Dim X As String

On Error Resume Next

X = TextBox1.Value

clc_URL.Add X, CStr(X) '新导航网址后，将新导航的网页地址存入集合clc_URL

If Err = 0 Then '若果错误为0即不重复

URL_Array(i) = X '将不重复的地址传送到地址素组URL_Array( )，且下面进行i递增1

i = i + 1

End If

Err.Clear '若有错，则清除错误

On Error GoTo 0

BackBtn.Enabled = True

ForwardBtn.Enabled = True

End Sub

'浏览器控件当准备产生新窗口时

Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)

Cancel = True '终止在新窗口产生网页为真

WebBrowser1.Navigate strURL '浏览器控件网址导航网址为中间传递的网址变量strURL

s = "" '当新网页欲想在新窗口中呈现时，重新先将s置空

End Sub

'浏览器控件状态文本改变时（即 活动网页中点击了的文本--超链接对象），将超链接的文本链接信息Text传递到

'中间传递的网址变量strURL

Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)

strURL = Text

End Sub

Private Sub HomeBtn_Click() '回到主页

WebBrowser1.GoHome

End Sub

Private Sub BackBtn_Click() '页面后退

firstURL = URL_Array(0) '获取地址数组存放网页的首址

'若地址栏为空，或者地址栏为空白，或者地址栏是网页的首址

If TextBox1.Value = "" Or TextBox1.Value = "about:blank" Or TextBox1.Value = firstURL Then

MsgBox "No site display or arrived at first site address!"

BackBtn.Enabled = False

Else

WebBrowser1.GoBack

ForwardBtn.Enabled = True

End If

End Sub

Private Sub ForwardBtn_Click() '页面前进

If TextBox1.Value = "" Then

lastURL = URL_Array(0)

MsgBox "No site display or arrived at last site address!!"

ForwardBtn.Enabled = False

Else

lastURL = URL_Array(clc_URL.Count - 1) '获取地址数组存放网页跳转的当前尾址

'若地址栏为空白，或者地址栏是网页跳转的最终当前尾址

If TextBox1.Value = "about:blank" Or TextBox1.Value = lastURL Then

MsgBox "No site display or arrived at last site address!!"

ForwardBtn.Enabled = False

Else

WebBrowser1.GoForward

BackBtn.Enabled = True

End If

End If

End Sub

Private Sub RefreshBtn_Click() '刷新页面

If TextBox1.Value = "" Then '如果地址栏输入框TextBox1为空

BackBtn.Enabled = True '则恢复后退BackBtn、前进ForwardBtn按钮可用，且不刷新页面

ForwardBtn.Enabled = True

Else '否则，刷新页面，并且调用过程Page_Title更改窗体标题

WebBrowser1.Refresh

Call Page_Title '刷新后调用网页标题去修改窗体标题功能

Call userform1_max_min_Btn_display '恢复最大化、最小化按钮显示

End If

End Sub

Private Sub StopBtn_Click() '页面停止

WebBrowser1.Stop

End Sub

'以下是窗体上相对浏览器控件WebBrowser1的几个控制按钮的事件

Private Sub About_Blank_Btn_Click() '设置空白页

WebBrowser1.Navigate "about:blank"

End Sub

Private Sub WebPagesHtmlSourceCodeBtn_Click() '查看访问当前网页的HTML源码

If TextBox1.Value <> "" Then '若地址收入栏非空

s = "" '当点击源码查看按钮WebPagesHtmlSourceCodeBtn时，s源码字符串置空

's获取最新访问的网页的源码（用WebBrowser1.Document.DocumentElement.innerHTML轻易实现）

s = s & WebBrowser1.Document.DocumentElement.innerHTML

Else

s = "No Web Pages!"

End If

MsgBox s

End Sub

Sub userform1_max_min_Btn_display() '窗体的最大化最小化按钮显示

Dim hWndForm As Long

Dim IStyle As Long

hWndForm = FindWindow("ThunderDFrame", Me.Caption)

IStyle = GetWindowLong(hWndForm, GWL_STYLE)

IStyle = IStyle Or WS_THICKFRAME '还原

IStyle = IStyle Or WS_MINIMIZEBOX '最小化

IStyle = IStyle Or WS_MAXIMIZEBOX '最大化

SetWindowLong hWndForm, GWL_STYLE, IStyle

PostMessage hWndForm, WM_SYSCOMMAND, SC_MAXIMIZE, 0 '使其窗口最大化

End Sub

三、浏览器运行测试效果截图

(一)在浏览器地址栏输入电子科技大学网址

(二)电子科技大学历史页面

(三)浏览器地址栏输入成都农业科技职业学院网址的页面

(四)点击成都农业科技职业学院站群导航准备进入信息技术分院

(五)点击成都农业科技职业学院站群导航进入信息技术分院

(六)点击Home按钮回到浏览器空白主页

好了，我终于分享给大家了全部的设计过程，各位可以可圈可点，可以在这个基础上进行改进开发，比如设计选项卡式的面板、站点收藏、历史纪录等等功能。

最后，还是感谢大家的关注（头条号“跟我学office高级办公”）和点评哦！

+