18.1 Excel中的用户界面
18.2 原始控件
18.2.1 无处不在的按钮
18.2.2 自由选择
代码清单18.1: 控制工作表的可视度
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单18.1: 控制工作表的可视度
Sub SetWorksheetVisibility()
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Checks and Options")
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Sheet1").Visible = CInt(ws.Range("ViewSheet1").Value)
ThisWorkbook.Worksheets("Sheet2").Visible = CInt(ws.Range("ViewSheet2").Value)
ThisWorkbook.Worksheets("Sheet3").Visible = CInt(ws.Range("ViewSheet3").Value)
Application.ScreenUpdating = True
Set ws = Nothing
End Sub
Sub SetWorksheetVisibility()
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Checks and Options")
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Sheet1").Visible = CInt(ws.Range("ViewSheet1").Value)
ThisWorkbook.Worksheets("Sheet2").Visible = CInt(ws.Range("ViewSheet2").Value)
ThisWorkbook.Worksheets("Sheet3").Visible = CInt(ws.Range("ViewSheet3").Value)
Application.ScreenUpdating = True
Set ws = Nothing
End Sub
代码清单18.2: 确定缩放范围的程序
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单18.2: 确定缩放范围的程序
Sub ScaleOption()
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Checks and Options")
ws.Range("ReportRange").NumberFormat = ws.Range("ReportScale").Value
Set ws = Nothing
End Sub
Sub ScaleOption()
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Checks and Options")
ws.Range("ReportRange").NumberFormat = ws.Range("ReportScale").Value
Set ws = Nothing
End Sub
18.2.3制作一个列表
代码清单18.3: 协调列表信息
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单18.3: 协调列表信息
Sub GetVerdict()
Dim ws As Worksheet
Dim nChildNumber As Integer
Dim sVerdict As String
On Error Resume Next
Sub GetVerdict()
Dim ws As Worksheet
Dim nChildNumber As Integer
Dim sVerdict As String
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Lists")
nChildNumber = ws.Range("ChildNumber")
'Get the current verdict associated with the child
sVerdict = ws.Range("ChildList").Offset(nChildNumber, 1)
If sVerdict = "Naughty" Then
'Activate the Naughty option
ws.Range("Verdict").Value = 1
Else
'Activate the nice option
ws.Range("Verdict").Value = 2
End If
Set ws = Nothing
End Sub
Sub SetVerdict()
Dim ws As Worksheet
Dim nChildNumber As Integer
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Lists")
nChildNumber = ws.Range("ChildNumber")
If ws.Range("Verdict").Value = 1 Then
'Update the child's verdict to Naughty
ws.Range("ChildList").Offset(nChildNumber, 1).Value = "Naughty"
Else
'Update the child's verdict to Nice
ws.Range("ChildList").Offset(nChildNumber, 1).Value = "Nice"
End If
Set ws = Nothing
End Sub
18.2.4 滚动和微调
代码清单18.4: 调整列宽
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单18.4: 调整列宽
Sub AdjustColumns()
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Spinners")
ws.Columns.ColumnWidth = ws.Range("ColumnWidth").Value
Sub AdjustColumns()
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Spinners")
ws.Columns.ColumnWidth = ws.Range("ColumnWidth").Value
Set ws = Nothing
End Sub
18.3 好像儿童进了糖果商店
18.4 通过封面判断内容
代码清单18.5: 创建一个超链接菜单
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单18.5: 创建一个超链接菜单
'Create a hyperlink to each worksheet in the
'workbook excluding the worksheet containing rgLinks.
Sub CreateLinks(rgLinks As Range)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> rgLinks.Parent.Name Then
rgLinks.Hyperlinks.Add rgLinks, ThisWorkbook.Name, "," & ws.Name & "'!A1", ws.Name, ws.Name
Set rgLinks = rgLinks.Offset(1, 0)
End If
Next
Set ws = Nothing
End Sub
'Example of how to use the CreateLinks procedure
'to create hyperlinks on the Menu worksheet.
'Assumes a range name "TOC" is present that
'represents where the links should go.
Sub CreateMenuLinks()
CreateLinks ThisWorkbook.Worksheets("Menu").Range("TOC").Offset(1, 0)
End Sub
'Create a hyperlink to each worksheet in the
'workbook excluding the worksheet containing rgLinks.
Sub CreateLinks(rgLinks As Range)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> rgLinks.Parent.Name Then
rgLinks.Hyperlinks.Add rgLinks, ThisWorkbook.Name, "," & ws.Name & "'!A1", ws.Name, ws.Name
Set rgLinks = rgLinks.Offset(1, 0)
End If
Next
Set ws = Nothing
End Sub
'Example of how to use the CreateLinks procedure
'to create hyperlinks on the Menu worksheet.
'Assumes a range name "TOC" is present that
'represents where the links should go.
Sub CreateMenuLinks()
CreateLinks ThisWorkbook.Worksheets("Menu").Range("TOC").Offset(1, 0)
End Sub