辑程序集

辑程序集汇编了9个小程序，分别运用了工作簿事件、工作表事件、以及讲述了一个进度条示例和将公式结果转换为值的小技巧。
下面为第9辑VBA程序集的内容，包含程序说明、代码和示例文档。
程序46：阻止另存为命令的使用
程序47：阻止用户打印工作簿
程序48：阻止打印工作簿中的部分工作表
程序49：阻止用户在工作簿中添加新工作表
程序50：工作表列A的值改变时,重新排序
程序51：UCase函数的使用
程序52：自动标记指定单元格所在行的颜色
程序53：一个进度条示例
程序54：将公式结果转换为值
[提示]如果您暂时不理解程序，您可以在工作簿中试运行，并改变工作簿中的内容后再运行，以查看运行后的结果，以此来促进程序的理解。

----------------------------------------------------------------------

程序46：阻止另存为命令的使用
本示例将阻止在工作簿中选择菜单“文件——另存为”命令的使用。当您选择“另存为”命令后，将会弹出一个消息框，告诉您不能使用另存为命令更改工作簿的名称。但您可以对该工作簿进行重命名。
下面的代码放置在ThisWorkbook代码模块中：
‘*****************************************************
Private Sub workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim lReply As Long
  If SaveAsUI = True Then
     lReply = MsgBox("对不起,您不能用其它名称保存本工作簿. ", vbQuestion + vbOKCancel)
     Cancel = (lReply = vbCancel)
     If Cancel = False Then Me.Save
     Cancel = True
  End If
End Sub
‘*****************************************************
示例文档见 (程序46)在工作簿中阻止另存为命令的使用.xls。UploadFiles/2006-9/919340817.rar

程序47：阻止用户打印工作簿
本示例演示当用户试图进行"打印预览"或"打印"时，将弹出不能打印本工作簿的消息框，因而不能对该工作簿进行打印预览或打印操作。
下面的代码放置在ThisWorkbook代码模块中：
‘*****************************************************
Private Sub workbook_BeforePrint(Cancel As Boolean)
    Cancel = True
    MsgBox "对不起,您不能打印本工作簿.", vbInformation
End Sub
‘*****************************************************
示例文档见 (程序47)阻止用户打印工作簿.xls。UploadFiles/2006-9/919551315.rar

程序48：阻止打印工作簿中的部分工作表
本程序将阻止用户打印工作簿中所指定的部分工作表，即在这些工作表中(如工作表Sheet1和Sheet2)使用“打印预览”和”打印”功能时，将弹出不能打印的消息框。而可以对其它工作表进行正常的打印预览和打印操作。
下面的代码放置在ThisWorkbook代码模块中：
‘*****************************************************
Private Sub workbook_BeforePrint(Cancel As Boolean)
    Select Case ActiveSheet.Name
        Case "Sheet1", "Sheet2"
            Cancel = True
            MsgBox "对不起,您不能打印本工作簿中的这个工作表", vbInformation
    End Select
End Sub
‘*****************************************************
示例文档见 (程序48)阻止用户打印工作簿中的部分工作表.xls。UploadFiles/2006-9/919298231.rar

程序49：阻止用户在工作簿中添加新工作表
本程序将阻止用户在新工作簿中添加新工作表，即当用户选择插入新工作表命令时，将会弹出不允许添加新工作表的消息框且不能添加新的工作表。
下面的代码放置在ThisWorkbook代码模块中：
‘*****************************************************
Private Sub Workbook_NewSheet(ByVal Sh As Object)
   Application.DisplayAlerts = False
   MsgBox "对不起,您不能在本工作簿中添加新的工作表", vbInformation
   Sh.Delete
   Application.DisplayAlerts = True
End Sub
‘*****************************************************
示例文档见 (程序49)阻止用户添加新工作表.xls。UploadFiles/2006-9/919443909.rar

程序50：工作表列A的值改变时,重新排序
在本示例中，如果您对工作表Sheet1中A列的值改变或在A列中添加值，工作表会对A列到D列中的数据进行重新排序(数据是动态的)，并相应的行进行调整，同时工作表Sheet2中的数据进行同步更新。
将下面的程序代码输入到工作表Sheet1模块中：
‘*****************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Column <> 1 Then Exit Sub
   Worksheets("Sheet2").Range(Target.Address).Value = Target.Value
   Range(("A1"), Cells(Rows.Count, 1).End(xlUp).Offset(0, 3)).Sort _
   key1:=Range("A2"), order1:=xlAscending, header:=xlYes
   Range("A:D").Copy Worksheets("Sheet2").Range("A:D")
End Sub
‘*****************************************************
示例文档见 (程序50)对A列排序并调整相应的行.xls。UploadFiles/2006-9/919786958.rar

程序51：UCase函数的使用
当您在工作表的A列中输入小写字母时，自动转换成大写字母，使用Ucase函数。
将下面的程序代码输入到工作表Sheet1模块中：
‘*****************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
   If IsEmpty(Target) Then Exit Sub
   If Target.Cells.Count > 1 Then Exit Sub
   If Target.Column > 1 Then Exit Sub
   Application.EnableEvents = False
   Target.Value = UCase(Target.Value)
   Application.EnableEvents = True
End Sub
‘*****************************************************
示例文档见 程序(51)自动转换成大写.xls。UploadFiles/2006-9/919229786.rar

程序52：自动标记指定单元格所在行的颜色
在本示例中，当您在相应的单元格中输入指定值时，会自动在工作表已使用区域内标记该单元格所在行的颜色；如果您删除相应单元格中的内容，颜色同时消失。参见解析UsedRange属性示例三。
‘*****************************************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim r As Long
  For r = UsedRange.Rows.Count To 1 Step -1
    If Range("E" & r) = "finish" Then _
      Range("A:G").Rows(r).Interior.ColorIndex = 10
    Next r
  For r = UsedRange.Rows.Count To 1 Step -1
    If Range("E" & r) = "" Then _
      Range("A:G").Rows(r).Interior.ColorIndex = 2
  Next r
End Sub
‘*****************************************************
当然，您可以修改上面的程序，将单元格或内容换成您想要的单元格或内容。
示例文档见 (程序52)自动标识行.xls。UploadFiles/2006-9/919895942.rar

程序53：一个进度条示例
在本示例中，当打开工作簿时会弹出一个窗口并显示进度条和信息。
在VBE编辑器中，插入一个用户窗体并布局，在窗体中有一个图片控件、一个进度条和三个标签。然后写代码如下。
以下为用户窗体中相关控件的代码：
 ‘*****************************************************
Private Sub UserForm_Initialize()
  Label3.Caption = Format(Now, "dddd d mmmm yyyy hh:mm:ss")
End Sub
‘*****************************************************
Private Sub UserForm_Activate()
  Dim dTime As Date
  Dim i As Integer
  For i = 1 To 100 Step 100 / 8
    dTime = Now + TimeValue("0:00:01")
    Application.Wait TimeValue(dTime)
    ProgressBar1.Value = i
  Next i
End Sub
‘*****************************************************
Private Sub Label2_Click()
  ThisWorkbook.FollowHyperlink "http://fanjy.blog.excelhome.net"
End Sub
‘*****************************************************
以下为工作簿中的代码，实现当工作簿打开时显示用户窗体。
‘*****************************************************
Private Sub Workbook_Open()
  Application.OnTime EarliestTime:= _
  Now + TimeValue("00:00:08"), Procedure:="EndSplash"
  UserForm1.Show
End Sub
‘*****************************************************
卸载用户窗体的代码：
‘*****************************************************
Sub EndSplash()
  Unload UserForm1
End Sub
‘*****************************************************
注意，用户窗体等待时间与进度条控制时间应一致。
示例文档见 (程序53)一个进度条示例.xls。UploadFiles/2006-9/919890160.rar

程序54：将公式结果转换为值
本示例将由公式所产生的结果转换为数值，即按要求运行程序后，公式单元格区域将转换成数值。当您再编辑这些区域时，不会显示公式，而是数值。
‘*****************************************************
Sub ValuesOnly()
  Dim rRange As Range
  On Error Resume Next
  Set rRange = Application.InputBox(Prompt:="请选取公式单元格区域", _
   Title:="转换为数值", Type:=8)
  If rRange Is Nothing Then Exit Sub
  rRange = rRange.Value
End Sub
‘*****************************************************