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

下面是代码的图片版：