VBA代码库06:实现健壮的“另存为”功能 |
您所在的位置:网站首页 › excel用宏实现另存为 › 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 下面是代码的图片版: ![]() ![]() |
今日新闻 |
点击排行 |
|
推荐新闻 |
图片新闻 |
|
专题文章 |
CopyRight 2018-2019 实验室设备网 版权所有 win10的实时保护怎么永久关闭 |