一起学Excel专业开发18：Excel工时报表与分析系统开发（2）——创建特定应用加载宏（续）
一起学Excel专业开发18：Excel工时报表与分析系统开发（2）——创建特定应用加载宏（续）
将工时输入工作簿中的副本保存到预先设定好的合并区
图1所示的自定义工具栏中的第一个按钮的作用是将工时输入工作簿的副本保存到合并区，其代码如下：
'保存已完成的工时输入工作簿副本到指定的合并位置
Public Sub PostTimeEntriesToNetwork()
Dim sSheetTab As String
Dim sWeekEndDate As String
Dim sEmployee As String
Dim sSaveName As String
Dim sSavePath As String
Dim wksSheet As Worksheet
Dim wkbBook As Workbook
Dim vFullName As Variant
'当工时输入工作簿为当前工作簿时才进行处理
'wkbBook返回对该工作簿的引用
If bIsTimeEntryBookActive(wkbBook) Then
'确保工时输入工作表没有任何数据输入错误
sSheetTab = sSheetTabName(wkbBook,gsSHEET_TIME_ENTRY)
Set wksSheet =wkbBook.Worksheets(sSheetTab)
If wksSheet.Range(gsRNG_HAS_ERRORS).Value Then
MsgBox gsERR_DATA_ENTRY,vbCritical, gsAPP_NAME
Exit Sub
End If
'为工时输入工作簿创建唯一的名字
sWeekEndDate = Format$( _
wksSheet.Range(gsRNG_WEEK_END_DATE).Value, _
"YYYYMMDD")
sEmployee = wksSheet.Range(gsRNG_EMPLOYEE_NAME).Value
sSaveName = sWeekEndDate & " -" & sEmployee & ".xlsx"
'检查注册表来判断是否已经指定了合并路径
'如果是,保存工时输入工作簿到该位置
'如果不是,提示用户指定合并路径,保存该位置到注册表
'保存工时输入工作簿到该位置
sSavePath = GetSetting(gsREG_APP,gsREG_SECTION, _
gsREG_KEY, "")
If Len(sSavePath) = 0 Then
'没有路径被存储在注册表
'提示用户进行注册
vFullName =Application.GetOpenFilename( _
Title:=gsCAPTION_SELECT_FOLDER)
If vFullName <> False Then
sSavePath = Left$(vFullName, _
InStrRev(vFullName,"\"))
SaveSetting gsREG_APP,gsREG_SECTION, _
gsREG_KEY, sSavePath
Else
'用户取消对话框
MsgBox gsMSG_POST_FAIL, vbCritical,gsAPP_NAME
Exit Sub
End If
End If
wkbBook.SaveCopyAs sSavePath &sSaveName
MsgBox gsMSG_POST_SUCCESS,vbInformation, gsAPP_NAME
Else
MsgBox gsMSG_BOOK_NOT_ACTIVE,vbExclamation, gsAPP_NAME
End If
End SubPostTimeEntriesToNetwork过程中，首先判断接口工作簿是否处于活动状态，这样可以防止用户单击工具栏中的按钮时，接口工作簿不是当前工作簿而导致的运行时错误。用于判断工作簿是否是当前工作簿的自定义函数为：
Public Function bIsTimeEntryBookActive(ByRef wkbBook As Workbook) As Boolean
On Error Resume Next
Set wkbBook = Nothing
Set wkbBook =Application.Workbooks(gsFILE_TIME_ENTRY)
On Error GoTo 0
If Not wkbBook Is Nothing Then
bIsTimeEntryBookActive = (wkbBook.Name= Application.ActiveWorkbook.Name)
End If
End Function在确认工作簿激活后，检查工时输入工作表中隐藏列的错误标识，确定工作表是否存在输入错误。如果存在输入错误，则向用户显示出错信息并退出过程，否则就为工作簿创建一个唯一的名称，然后在注册表中查询合并区的路径。如果合并区的路径并未保存到注册表，则会给出提示信息并要求用户指定其路径。最后，调用Workbook对象的SaveCopyAS方法将工作簿副本保存到合并区，并给出提示信息告诉用户操作成功。
允许用户向“工时输入”工作表中添加更多的数据输入行
图1所示的自定义工具栏中的第二个按钮可用来增加数据输入区的行数，代码如下：
'允许用户在工时输入表数据区底部插入空的数据输入行
Public Sub AddMoreRows()
Const lOFFSET_COLS As Long = 5
Const lINPUT_COLS As Long = 6
Dim rngInsert As Range
Dim wkbBook As Workbook
Dim wksSheet As Worksheet
'工时输入工作簿是活动的才继续操作
If bIsTimeEntryBookActive(wkbBook) Then
'获取对工时输入工作表的引用并在其中插入行区域
'所有新行被插入到这个区域之上
Set wksSheet =wkbBook.Worksheets(sSheetTabName( _
wkbBook,gsSHEET_TIME_ENTRY))
Set rngInsert =wksSheet.Range(gsRNG_INSERT_ROW)
'在工时输入工作表中添加新行
wksSheet.Unprotect
wksSheet.ScrollArea = ""
rngInsert.EntireRow.Insert
rngInsert.Offset(-2, 0).EntireRow.Copy_
Destination:=rngInsert.Offset(-1,0)
rngInsert.Offset(-1, lOFFSET_COLS) _
.Resize(1,lINPUT_COLS).ClearContents
wksSheet.ScrollArea = _
wksSheet.Range(gsRNG_SET_SCROLL_AREA).Address
wksSheet.Protect , True, True, True
Else
MsgBox gsMSG_BOOK_NOT_ACTIVE,vbExclamation, gsAPP_NAME
End If
End Sub添加新数据输入行的步骤如下：
1.直接在数据输入区的最后一行上方插入新行，其最后一行的预定义名称设置为gsRNG_INSERT_ROW。
2.复制新添加行上面一行的数据，并将其粘贴到新加入行内。这样可将各种保证表格正确操作和显示的设置（如函数、格式和数据验证等）添加到新加入行中。
3.将新添加行中的数据全部清除，为数据输入做好准备。
注意，在插入新行之前先删除工作表滚动区域设置，插入新行后再重新添加滚动区域设置。如果不这么操作，那么在插入新行时工作表滚动区无法进行正确调整。
允许用户清除数据输入区域中的数据，以便重新使用工时输入表
图1所示的自定义工具栏中的第三个按钮用于清除工时输入表数据输入区中的数据，代码如下：
'清除当前工作表中的数据输入单元格内容
'以便再次利用数据输入区进行数据输入
Public Sub ClearDataEntryAreas()
Dim rngToClear As Range
Dim wkbBook As Workbook
'工时输入工作簿是活动的才继续操作
If bIsTimeEntryBookActive(wkbBook) Then
'确保当前工作表中有一个名称为rgnClearInputs的区域
On Error Resume Next
Set rngToClear = _
wkbBook.ActiveSheet.Range("rgnClearInputs")
On Error GoTo 0
'如果工作表是输入工作表,清除输入区的内容
If Not rngToClear Is Nothing Then
rngToClear.ClearContents
End If
Else
MsgBox gsMSG_BOOK_NOT_ACTIVE,vbExclamation, gsAPP_NAME
End If
End Sub允许用户关闭PETRAS程序
图1所示的自定义工具栏中的第四个按钮用于关闭PETRAS程序并删除自定义工具栏，代码如下：
'退出PETRAS程序
Public Sub ExitApplication()
ShutdownApplication
End Sub关闭操作实际上是由ShutdownApplication过程来完成的，在Auto_Close过程中也调用了这个过程。该过程的代码为：
'关闭程序
Public Sub ShutdownApplication()
'忽略应用程序关闭时的任意错误
On Error Resume Next
'这个标志避免该程序在ExitApplication过程中被调用后
'又被Auto_Close第二次调用
gbShutdownInProgress = True
'删除命令栏
Application.CommandBars(gsBAR_TOOLBAR).Delete
'关闭工时输入工作簿,允许用户保存修改
Application.Workbooks(gsFILE_TIME_ENTRY).Close
'如果没有打开的工作簿则退出Excel
'否则只是关闭该工作簿
If lCountVisibleWorkbooks() = 0 Then
ThisWorkbook.Saved = True
Application.Quit
Else
ThisWorkbook.Close False
End If
End Sub在ShutdownApplication过程中，有一个标志变量gbShutdownInProgress，用于防止当单击自定义工具栏中退出应用程序按钮时该过程被调用两次。这是因为在关闭加载宏工作簿时会触发过程Auto_Close，而Auto_Close过程会再次调用ShutdownApplication过程。有了这个标志变量后，Auto_Close过程会先对其进行检查，当发现关闭过程正在进行时就直接退出，从而避免发生两次调用。
ShutdownApplication过程首先删除自定义工具栏，然后关闭工时输入工作簿，如果该工作簿未保存，Excel提示用户要保存工作簿。在工时输入工作簿关闭后，该过程检查是否还有其他可见工作簿处于打开状态。如果没有，则关闭Excel。如果有可见工作簿处于打开状态，则只关闭该工作簿而不关闭Excel。
自定义函数lCountVisibleWorkbooks对可见工作簿进行计数：
'获取在Excel中目前打开的可见工作簿数量
Public Function lCountVisibleWorkbooks() As Long
Dim lCount As Long
Dim wkbBook As Workbook
For Each wkbBook In Application.Workbooks
If wkbBook.Windows(1).Visible Then
lCount = lCount + 1
End If
Next wkbBook
lCountVisibleWorkbooks = lCount
End Function添加自定义属性以便合并程序可据此查找“工时输入”工作簿的所有实例进程
当用户将自已的工时输入工作簿都保存到合并区后，合并程序就能对它们进行操作。而在合并区中，可能还存放着其他工作簿文件，这要求合并程序能够自动排除这些无关工作簿。实现方法是，为工时输入工作簿添加一个名为PetrasTimesheet的自定义文档属性，合并程序通过检测该属性是否存在来判断工作簿是否为我们需要的工时输入工作簿。
添加自定义文档属性的步骤如下：
1.单击”文件——信息——属性——高级属性”，弹出如下图2所示的对话框。
