VBA代码库06：实现健壮的“另存为”功能

学习Excel技术，关注微信公众号：
excelperfect

下面的自定义函数GetSaveAsFilenamePlus函数的代码能够更好地实现GetSaveAsFilename方法的“另存为”功能。该函数接受两个参数，分别是文件名和路径，用于“另存为”对话框中的默认值。如果用户输入的文件名已存在，则会询问用户是否覆盖掉已存在的文件、输入另一个文件名、或者取消保存操作。如果用户取消保存，则该函数返回零长字符串。

GetSaveAsFilenamePlus函数代码如下：
Function GetSaveAsFilenamePlus( _
   strFileName As String, _
   strPathName As String) As String
Dim strFullName As String
Dim strPrompt As String
Dim strCurDir As String
Dim iOverwrite As Long

If ActiveWorkbook Is Nothing Then
      GoTo ExitSub
End If

'保存当前目录,以便以后恢复
strCurDir = CurDir

'切换到所需要的目录
If Len(strPathName) > 0 Then
      ChDrive strPathName
      ChDir strPathName
End If

'循环直至输入了不同的文件名
Do
      strFullName = _
      Application.GetSaveAsFilename( _
      strFileName, _
      "Excel Files(*.xls*),*.xls*", , _
      "浏览到文件夹并输入文件名")

      If Len(strFullName) = 0 Then GoToExitSub
      If strFullName = "False" ThenGoTo ExitSub

      '如果文件名唯一,退出循环并保存文件
      If Not FileExists(strFullName) ThenExit Do

      '告诉用户文件名已存在

      '解析文件名
      strFileName =FullNameToFileName(strFullName)
      strPathName =FullNameToPath(strFullName)

      '消息字符串
      strPrompt = "名称为'" & strFileName &"'的文件已在'" _
         & strPathName & "'中."
      strPrompt = strPrompt & vbNewLine& vbNewLine & _
      "想要覆盖已存在的文件吗?"

      '询问用户要执行的操作
      iOverwrite = MsgBox(strPrompt,vbYesNoCancel + vbQuestion, _
      "文件已存在")

      Select Case iOverwrite
      Case vbYes
      '覆盖已存在的文件
         Exit Do
      Case vbNo
      '再次循环获得新文件名
      Case vbCancel
         GoTo ExitSub
      End Select
Loop

'使用上面的文件名保存文件
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strFullName
Application.DisplayAlerts = True

GetSaveAsFilenamePlus = strFullName

ExitSub:
'恢复为已前的默认目录
ChDrive strCurDir
ChDir strCurDir
End Function

在GetSaveAsFilenamePlus函数中调用的函数过程代码如下：
'判断文件是否已存在
'比Dir更灵活
Function FileExists(ByVal FileSpec As String) As Boolean
Dim Attr As Long
On Error Resume Next
Attr = GetAttr(FileSpec)
If Err.Number = 0 Then
'没有错误,表明找到
'如果设置了Directory属性则不是文件
      FileExists = Not ((Attr AndvbDirectory) = vbDirectory)
End If
End Function

'将包含路径和文件名的字符串解析并获取文件名
Function FullNameToFileName(sFullName As String) As String
Dim k As Integer
Dim sTest As String
If InStr(1, sFullName, "[") >0 Then
      k = InStr(1, sFullName, "[")
      sTest = Mid(sFullName, k + 1, InStr(1,sFullName, "]") - k - 1)
Else
      For k = Len(sFullName) To 1 Step -1
         If Mid(sFullName, k, 1) ="\" Then Exit For
      Next k
      sTest = Mid(sFullName, k + 1,Len(sFullName) - k)
End If
FullNameToFileName = sTest
End Function

'将包含路径和文件名的字符串解析并获取文件路径
Function FullNameToPath(sFullName As String) As String
'不包括结尾反斜线
Dim k As Integer
For k = Len(sFullName) To 1 Step -1
      If Mid(sFullName, k, 1) = "\"Then Exit For
Next k
If k < 1 Then
      FullNameToPath = ""
Else
      FullNameToPath = Mid(sFullName, 1, k - 1)
End If
End Function

使用下面的过程来测试GetSaveAsFilenamePlus函数：
Sub testGetSaveAsFilenamePlus()
Dim strFile As String
strFile =GetSaveAsFilenamePlus("sample.xlsm", "C:\")
If Len(strFile) > 0 Then
      MsgBox "文件已成功保存"
Else
      MsgBox "文件没有保存"
End If
End Sub

下面是代码的图片版：