2.3 文件查找与转换
查找文件及对文件进行格式转换可以手动实现，然而利用 VBA完成可以更高效。本节对磁盘中查找文件和网上查找文件，以及查找并播放MP3等进行答疑解惑。
疑难43 如何判断指定文件是否存在
利用VBA将工作簿保存为指定名称的文件时，如果已经存在同名文件，那么会覆盖原有文件；如果该文件处于打开状态，那么保存文件的代码将出错。最好的方式是保存前判断该目录中是否存在指定名称的文件，那么如何判断文件存在或者已打开呢？
解决方案
利用DIR函数获取文件名，如果文件名长度大于0则表示文件存在。而文件是否打开，则必须通过循环检测当前打开的所有文件名是否与指定的路径和名称相同。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Sub 判断文件是否存在() '用于文件保存前判断指定名称的文件是否存在，以及是否已打开
Dim FileName As String, PathStr As String, i As Integer
PathStr = "D:\生产表" '路径
FileName = "单价表.xlsx" '文件名
For i = 1 To Workbooks.Count '遍历所有打开的文件
'如果打开的工作簿全部等于指定的路径加文件名，那么提示已打开，且退出程序
If Workbooks(i).FullName = PathStr & "\" & FileName Then MsgBox
FileName & "已打开，无法以该名保存。": Exit Sub
Next
'如果文件存在，那么提示
If Len(Dir(PathStr & "\" & FileName)) > 0 Then
MsgBox PathStr & " 目录中已存在“" & FileName & "”，如果保存将会覆盖
原有数据，继续吗"
End If
End Sub
步骤3 光标置于代码中任意位置，并按【F5】键执行，如果用户的目录“D:\生产表”中有“单价表.xlsx”文件，那么将弹出图2-47所示的提示框；如果该文件已经打开，则会弹出图2-48所示的提示框；如果文件不存在，那么可以继续后面的操作。读者可以在程序后面加入文件保存或者其他代码继续执行。
█ 图2-47 指定文件已存在的提示
█ 图2-48 指定路径下同名文件已打开时的提示
原理分析
※ 利用DIR函数判断文件是否存在 ※
DIR 函数用于获取文件或者文件夹名称，如果文件或者文件夹不存在则返回空字符，利用该特征计算DIR函数返回值的长度，即可判断文件或者文件夹是否存在。
已打开的文件的 Name 属性仅仅显示文件名，而磁盘中有可能存在多个同名文件，所以判断指定文件是否打开时，需要使用包括路径的“FullName”属性。
知识扩展
判断文件是否存在还有一个专用的函数，可以直接实现，即利用FSO对象完成：
MsgBox CreateObject("Scripting.FileSystemObject").FileExists("D:\生产表\单价表.xlsx")
利用For...Next循环判断文件是否存在，当已找到目标时，需要退出循环即“Exit Sub”或者“Exit For”，否则将浪费时间继续进行不必要的循环。
疑难44 如何进行深度查找且创建文件目录
如何对文件夹中的文件创建目录？如果有子目录需要包括其子目录中所有文件。
解决方案
利用FileDialog对象弹出对话框让用户选择待创建目录的文件夹。当用户选择文件夹后，通过DIR函数判断文件夹中的子项是文件还是文件夹。如果是文件则将其路径、文件名和大小写入数组变量中，如果是文件夹，则调用文件搜索过程继续进行文件查找。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Dim arr(), i '声明公共变量，供两个过程调用
Sub 提取文件清单()
Dim fd As Object, PathStr As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'打开选择文件的对话框
With fd '如果选择了目录则提取目录的路径，否则退出程序
If .Show = -1 Then PathStr = .SelectedItems(1) Else Exit Sub
End With
If Right(PathStr, 1) <> "\" Then PathStr = PathStr & "\"
'如果路径右边没有"\"则追加一个
Cells.Clear '清除所有单元格的数据
Application.ScreenUpdating = False '关闭屏幕更新
i = 0
Call 查找(PathStr) '执行查找程序
'如果找到有文件，则所有数组的值导入到单元格中，数组中包括所有找到的文件
If i > 0 Then [a2].Resize(i, 3) = WorksheetFunction.Transpose(arr)
[a1:c1].EntireColumn.AutoFit '按字符自动调整宽度
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
Public Sub 查找(ByVal 路径 As String) '查找文件的过程
Dim Dirs() As String, Dir_Count As Long, File_Name As String, File_Name_2
As String, j
If Right(路径, 1) <> "\" Then 路径 = 路径& "\"
'如果路径最后一位非“\”则追加一个“\”
File_Name = Dir(路径& "*.*", vbDirectory) '获取文件目录名称
Do While Len(File_Name) <> 0
'只要文件目录名存在（目录字符长度大于0）就循环下去
If Left$(File_Name, 1) <> "." Then '如果左边第一字符为"."
File_Name_2 = 路径& File_Name '获取子目录
If (GetAttr(File_Name_2) And vbDirectory) = vbDirectory Then
'如果是文件夹
Dir_Count = Dir_Count + 1 '计算子目录数量
ReDim Preserve Dirs(1 To Dir_Count) As String '重新声明数组的存储空间
Dirs(Dir_Count) = File_Name_2 '将子目录名称写入数组Dirs中
Else '如果不是文件夹目录
i = i + 1 '累加变量，该变量等于文件数量
ReDim Preserve arr(1 To 3, 1 To i) '重新声明数组的存储空间
arr(1, i) = 路径 '将文件路径写入数组
arr(2, i) = File_Name '将文件名写入数组
arr(3, i) = FileLen(路径& File_Name) / 1024 / 1024
'将文件大小写入数组
End If
End If
File_Name = Dir() '查找下一个文件
Loop
For j = 1 To Dir_Count '遍历数组Dirs，即对子目录进行查找
查找 Dirs(j) '调用自身再执行文件查找
Next j
End Sub
步骤3 将光标置于代码中任意位置，并按【F5】键执行，将弹出一个选择文件夹的对话框。假设选择E盘的文件夹“歌”，并单击“确定”按钮，那么程序会瞬间将“D:\歌”下的所有文件及子文件夹中的所有文件信息写入到单元格中，如图2-49所示。
█ 图2-49 创建文件目录
原理分析
※ FileDialog对象的应用 ※
FileDialog对象是Excel内置的文件对话框，包括4个参数，代表4种典型的对话框。当参数为 msoFileDialogFilePicker 时显示一个“文件选取器”对话框；当参数为 msoFileDialog FolderPicker时显示一个“文件夹选取器”对话框；当参数为msoFileDialogOpen时显示一个“打开”对话框；当参数为msoFileDialogSaveAs时显示一个“另存为”对话框。
DIR函数可提取文件或者文件夹名，而GetAttr函数可用于判断一个对象是文件或文件夹。那么DIR和GetAttr函数搭配即可以获取文件名、文件夹名及子文件夹中的文件名。程序的重点在于递归，当GetAttr函数判断出当前对象是文件夹时，调用程序自身再次进行文件搜索。
知识扩展
本例创建了文件目录，包括目录名、文件名和文件大小等信息。如果需要实现单击文件名时可以打开对应的文件，那么还可以对B列的文件创建超链接，代码如下：
Sub 文件链接()
For j = 2 To Cells(Rows.Count, 2).End(xlUp).Row
ActiveSheet.Hyperlinks.Add Cells(j, 2), Cells(j, 1) & Cells(j, 2)
Next j
End Sub
每找到一个文件后可以即时写入单元格中，但借用数组做中介可以大大提速。
疑难45 如何查找并备份所有“3月生产表”
公司有多个生产部门，各部门的生产表按不同文件夹存放，而每个部门都有“3月生产表.xls”，现需将其备份到桌面“备份”文件夹中，如何才能一次备份所有表？如图2-50所示，每个组中都有“3月生产表”，而且其子文件夹中也可能有“3月生产表”。
解决方案
利用DIR函数配合DO 循环进行全盘文件搜索，将找到的所有“3月生产表.xls”完整名称加入数组中。再使用脚本语言获取桌面路径，配合FSO对象的CopyFile方法备份文件。
█ 图2-50 D盘中生产表分布
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Dim arr(), i '声明公共变量，供两个过程调用
Public Sub 查找(ByVal 路径 As String) '查找文件的过程
Dim Dirs() As String, Dir_Count As Long, File_Name As String, File_Name_2
As String, j
If Right(路径, 1) <> "\" Then 路径 = 路径& "\"
'如果路径最后一位非“\”则追加一个“\”
File_Name = Dir(路径& "*.*", vbDirectory) '获取文件名称
Do While Len(File_Name) <> 0 '只要文件目录名存在（目录字符长度大于0）就循环下去
If Left$(File_Name, 1) <> "." Then '如果左边第一字符为“.”
File_Name_2 = 路径& File_Name '获取子目录
If (GetAttr(File_Name_2) And vbDirectory) = vbDirectory Then
'如果是文件夹
Dir_Count = Dir_Count + 1 '计算子目录数量
ReDim Preserve Dirs(1 To Dir_Count) As String '重新声明数组的存储空间
Dirs(Dir_Count) = File_Name_2 '将子目录名称写入数组Dirs中
Else '如果不是文件夹目录
If File_Name = "3月生产表.xls" Then
i = i + 1 '累加变量，该变量等于文件数量
ReDim Preserve arr(1 To i) '重新声明数组的存储空间
arr(i) = 路径& File_Name '将文件名写入数组
End If
End If
End If
File_Name = Dir() '查找下一个文件
Loop
For j = 1 To Dir_Count '遍历数组Dirs，即将子目录进行查找
查找 Dirs(j) '调用自身再执行文件查找
Next j
End Sub
'在D盘查找所有“3月生产表.xls”，然后备份到桌面“备份”文件夹中，备份文件名等于原文
'件名加其上层文件夹名
Sub 备份所有3月生产表()
Dim PathStr As String
'将备份的完整路径赋值给变量，其中桌面路径利用脚本语言获取
PathStr = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\备份\"
'如果桌面不存在“备份”文件夹，那么利用FSO对象创建一个文件夹
If Len(Dir(PathStr, vbDirectory)) = 0 Then
CreateObject("Scripting.FileSystemObject").createfolder PathStr
i = 0
Call 查找("d:\") '调用查找程序
If i > 0 Then '如果文件数量大于0
For j = 1 To i '遍历每个文件（数组的每个元素）
'利用FSO技术的CopyFile方法进行文件复制，复制后的文件等于文件夹名加文件名，其
'中桌面的地址由脚本语言WScript取得
CreateObject("Scripting.FileSystemObject").CopyFile arr(j), _
CreateObject("WScript.Shell").SpecialFolders ("Desktop") & "\备份
\[" & Replace(Split(arr(j), "\")(UBound(Split(arr(j), "\")) - 1)
& ")" & Split(arr(j), "\")(UBound(Split(arr(j), "\"))), ":", "盘")
Next
End If
End Sub
步骤3 光标置于过程“备份所有3月生产表”中任意位置，并按【F5】键执行，如果桌面没有“备份”文件夹，那么会自动创建该文件夹，然后将 D 盘中所有“3月生产表.xls”备份到“备份”文件夹中，如图2-51所示。备份的每个文件以其所在文件夹名加文件名组成，如果在根目录中，那么盘符冒号替换成“盘”。
原理分析
本例中查找文件的思路和疑难44基本一致，只不过对于查找到的文件需要筛选，仅仅留下“3月生产表.xls”。
█ 图2-51 备份所有“3月生产表”
※ CopyFile方法对文件复制 ※
在复制文件时，必须判断目标文件夹是否存在，这是防错的必要手段。FSO对象的CopyFile方法复制文件时允许复制后的文件名与被复制的文件名不一致，相当于复制并改名。所以本例中文件备份后其名称可以自动添加前缀以示区别。不过文件名有一个特点，“\”或者“:”等特殊符号不能作为文件名，对于根目录中的文件命名时需要将“:”替换成“盘”。
知识扩展
有很多需求VBA本身可能无法完成，或者能完成但步骤较多。VBA有一个优点，可以调用其他很多语言的代码，例如脚本、API、VBS、DOS、FSO 等。本例判断桌面路径时调用了脚本语言，而复制文件和创建文件夹时则采用了FSO语言。
根据文件的完整路径计算文件名和文件所在目录及盘符，用 Split 最方便快捷。因为文件路径的特点是以“\”作为分隔符，而Split正好以分隔符为条件将字符串转换成数组，利用数组的Item属性可以获取数组中的任意元素。
疑难46 如何将所有Excel文件转换成XPS或PDF文件
Windows 7和Vista支持XPS文件格式，该格式和 PDF 一样可以防止随意修改。Excel 文件通过“Microsoft XPS Document Writer”可以打印成XPS格式的文件。如何通过VBA实现文件夹下所有Excel文件瞬间转换呢？如果用户安装了Excel 2007或者2010，是否还可以转换成PDF呢？待转换的生产表如图2-52所示。
█ 图2-52 待转换的生产表
解决方案
XPS 是 Windows 7和Vista系统独有的功能，在所有软件的打印名称列表中都将出现“Microsoft XPS Document Writer”。将它设置打印机后即可通过打印到文件从而实现工作簿转换为 XPS，在 VBA 中对应的方法是：将它赋值给 PrintOut 方法的 ActivePrinter 参数，并对PrToFileName参数指定XPS文件路径。
只要在Windows 7和Vista中，Excel 2003、2007和2010都可以实现文件转XPS，但转PDF却需要Excel 2007 SP2及以上版本。Excel 2007 SP2和2010中都内置了PDF转换工具，对于未装SP2补丁的Office 2007及更早的Office版本将无法实现。在Excel 2010和2007的SP2中，有一个ExportAsFixedFormat方法可以实现，配合For...Next循环即可对文件夹中的所有文件进行批量转换。
操作方法
步骤1 将Excel的打印机设置为“Microsoft XPS Document Writer”。
步骤2 按【Alt+F11】组合键打开VBE窗口。
步骤3 选择菜单“插入”→“模块”，并输入以下代码：
Sub 批量将Excel文件转成XPS()
If InStr(Application.OperatingSystem, "6.") = 0 Then End
'如果不是Windows 7或Vista则不终止程序
If InStr(Application.ActivePrinter, " XPS ") = 0 Then End
'如果当前打印机名不包括XPS名称，则终止程序
Dim str As String, n As Long, fd, Nam As String
On Error GoTo err '程序出错时则退出
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd '显示一个选择文件夹的对话框，如果选择了文件夹则取其名称，否则退出
If .Show = -1 Then t = .SelectedItems(1) Else Exit Sub
End With
Application.ScreenUpdating = False '关闭屏幕更新，提高速度
str = Dir(t & "\*.xl*") '开始查找文件，格式为所有Excel文件
While Len(str) > 0
n = n + 1 '累加变量，该变量代表文件数量
Workbooks.Open (t & IIf(Right(t, 1) = "\", "", "\") & str) '打开工作簿
Nam = CreateObject("Scripting.FileSystemObject").getextensionname(str)
'获取文件的扩展名
'开始转换，通过打印到XPS文件实现转换。PrintToFile表示打印到文件，PrToFileName
'设为 True，表示需要手动指定文件路径，需要配合PrToFileName参数来实现
Sheets.PrintOut , , 1, , , True, True, (t & IIf(Right(t, 1) = "\", "",
"\") & Replace(str, Nam, "xps")), True
Workbooks(str).Close False '关闭工作簿
Kill (t & IIf(Right(t, 1) = "\", "", "\") & str) '删除工作簿
str = Dir() '查找下一个
Wend
Application.ScreenUpdating = True '恢复屏幕更新
err:
End Sub
步骤4 光标置于代码中任意位置，并按【F5】键执行，将弹出一个选择文件夹的对话框。从对话框中选择需要转换文件格式的文件夹，例如“D:\生产表”，单击“确定”按钮后将弹出图2-53所示的提示框，表示当前进度。最后的转换结果如图2-54所示。
█ 图2-53 打印提示
█ 图2-54 转换结果
步骤5 以上代码用于Windows 7或Vista中，可将工作簿转换为XPS格式。事实上目前更具广泛性的是PDF格式，Excel 2007 SP2和Excel 2010都集成了该插件，可以瞬间批量转换，代码如下：
Sub 批量将Excel文件转成PDF()
Dim str As String, n As Long, fd, Nam As String
On Error GoTo err '程序出错时则退出
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd '显示一个选择文件夹的对话框，如果选择了文件夹则取其名称，否则退出
If .Show = -1 Then t = .SelectedItems(1) Else Exit Sub
End With
Application.ScreenUpdating = False '关闭屏幕更新，提升速度
str = Dir(t & "\*.xl*") '开始查找文件，格式为所有Excel文件
While Len(str) > 0
n = n + 1 '累加变量，该变量代表文件数量
Workbooks.Open (t & IIf(Right(t, 1) = "\", "", "\") & str) '打开工作簿
Nam=CreateObject("Scripting.FileSystemObject").getextensionname(str)
'获取文件的扩展名
'开始进行格式转换，两个参数分别表示文件名、转换质量
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=(t
& IIf(Right(t, 1) = "\", "", "\") & Replace(str, Nam, "pdf")),
Quality:=xlQualityStandard
Workbooks(str).Close False '关闭工作簿
Kill (t & IIf(Right(t, 1) = "\", "", "\") & str) '删除工作簿
str = Dir() '查找下一个
Wend
Application.ScreenUpdating = True '恢复屏幕更新
err:
End Sub
步骤6 执行过程“批量将Excel文件转成PDF”，将弹出一个选择文件夹的对话框。从对话框中选择需要转换文件格式的文件夹，并单击“确定”按钮，那么该文件夹中所有文件都将转换成PDF文件。如图2-55和图2-56所示是文件转换前后对比效果。
█ 图2-55 转换前
█ 图2-56 转换后
原理分析
※ 利用PrintOut方法将工作表转换成XPS文件 ※
“Sheets.PrintOut”表示将所有工作表打印出来，而PrintToFile参数设为True时则可以打印到文件，通过 PrToFileName 参数指定 XPS 文件的路径。为了避免遗漏部分区域，IgnorePrintAreas参数必须设为True，表示不忽略打印区域而是打印整个对象。
ExportAsFixedFormat 方法可以将 Excel 的工作表或者工作簿转换成 PDF 文件，这建立在Excel已安装PDF转换插件的基础上。Excel 2007的SP2和Excel 2010都内置该插件，Excel 2007未装补丁情况下需要安装PDF转换插件，而早期版本无法安装该插件。
知识扩展
ExportAsFixedFormat方法包括工作簿级和工作表级。工作簿级的ExportAsFixedFormat可以将整个工作簿中所有工作表转换成PDF，而工作表级的ExportAsFixedFormat仅仅对当前表生效。
Workbook.ExportAsFixedFormat方法用于将工作簿发布为PDF或XPS 格式，其语法如下：
表达式.ExportAsFixedFormat(Type, Filename, Quality, IncludeDocProperties, IgnorePrint-Areas, From, To, OpenAfterPublish, FixedFormatExtClassPtr)
其中各参数含义如表2-3所示。
█ 表2-3 ExportAsFixedFormat参数列表
注意
本例中对文件夹中的文件进行转换，不转换其子文件夹中的文件。如果需要，读者可以借用疑难44的思路进行多层循环。
疑难47 如何在网上邻居的共享盘中查找并打开“单价表”
本机查找文件时，指定盘符与文件名即可。那么在网上邻居的共享文件夹中查找文件，如果存在就打开。应如何利用VBA实现？
解决方案
网上邻居和本机磁盘的差异在于：本机通过磁盘盘符访问，网上邻居通过 IP 地址访问。所以判断网上邻居文件是否存在，文件路径只要包含网上邻居的 IP 地址、共享目录和文件名即可。如果文件存在，则利用Workbooks.Open方法打开该文件。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Sub 在网上邻居查找并打开文件()
'如果网上邻居的共享文件夹中的文件存在
If
CreateObject("Scripting.FileSystemObject").FileExists("\\192.168.1.2\a
ndysky\单价表.xls") Then
Workbooks.Open "\\192.168.1.2\andysky\单价表.xls" '打开文件
End If
End Sub
步骤3 光标置于代码中任意位置，并按【F5】键执行，在IP地址为“192.168.1.2”、共享目录为“andysky”文件夹中有“单价表.xls”的话，会立即打开该文件，如果不存在该文件，或者该电脑未共享文件夹，那么程序会有几秒钟的停顿，然后自动退出程序。
原理分析
电脑对网上邻居电脑的识别以IP地址为基准，访问网上邻居的共享目录也需要IP地址作为识别依据。在编写路径时，“\”和小圆点都必须是半角状态输入才可访问。
知识扩展
※ 利用FileExists方法判断文件是否存在 ※
本例中 FileExists 方法属于 FSO对象，是判断文件或者文件夹是否存在的专用工具。FSO对象模型包含在 Scripting 类型库“Scrrun.Dll”中，它同时包含了 Drive、Folder、File、FileSystemObject和TextStream五个对象。如果系统中删除“Scrrun.Dll”则无法使用该链接库中的所有函数。所以在通用性上，它略逊于Dir函数。
如果需要打开的是网上邻居的文件夹而不是目录，可以使用Shell函数完成：
Sub 打开网上邻居的文件夹() Shell "explorer.exe \\192.168.1.2\andysky\", vbMaximizedFocus End Sub
疑难48 如何实现全盘查找“上海滩.MP3”，有则自动翻放
D盘中有很多音乐，如果现在想听“上海滩.MP3”，如何利用VBA自动定位并自动播放该MP3歌曲呢？
解决方案
动态链接库“winmm.dll”中包括了关于MP3文件播放的相关函数，包括MP3的播放、暂停、继续播放和关闭，以及判断是否播放完毕的函数。利用API声明调用该动态链接库可以实现文件的播放、暂停、关闭等功能。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Dim Pathstr As String
Private Declare Function Player Lib "winmm.dll" Alias "mciSendStringA"
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal
uReturnLength As Long, ByVal hwndCallback As Long) As Long
Sub mp3(ByVal 路径 As String) '查找文件的过程
Dim Dirs() As String, Dir_Count As Long, File_Name As String, File_Name_2
s String, j
If Right(路径, 1) <> "\" Then 路径 = 路径& "\" '如果路径最后一位非“\”则追
加一个“\”
File_Name = Dir(路径& "*.*", vbDirectory) '获取文件、目录名称
Do While Len(File_Name) <> 0
'只要文件目录名存在（目录字符长度大于0）就循环下去
If Left$(File_Name, 1) <> "." Then '如果左边第一字符为“.”
File_Name_2 = 路径& File_Name '获取子目录
If (GetAttr(File_Name_2) And vbDirectory) = vbDirectory Then
'如果是文件夹
Dir_Count = Dir_Count + 1 '计算子目录数量
ReDim Preserve Dirs(1 To Dir_Count) As String '重新声明数组的存储空间
Dirs(Dir_Count) = File_Name_2 '将子目录名称写入数组Dirs中
Else '如果不是文件夹目录
If File_Name = "上海滩.mp3" Then Pathstr = 路径& File_Name: Exit Sub
End If
End If
File_Name = Dir() '查找下一个文件
Loop
For j = 1 To Dir_Count '遍历数组Dirs，即将子目录进行查找
mp3 Dirs(j) '调用自身再执行文件查找
Next j
End Sub
Sub OpenMp3() '播放MP3
Call mp3("D:\") '执行文件查找
'如果变量Pathstr指向上海滩，那么开始播放
If Dir(Pathstr) = "上海滩.MP3" Then Player "Play """ & Pathstr & """",
"", 0, 0
End Sub
Sub CloseMp3() '关闭
' Player "close all", "", 1024, 0 '关闭所有音乐
Player "Close """ & Pathstr & """", "", 0, 0 '停止播放上海滩
End Sub
Sub PauseMp3() '暂停
'如果变量Pathstr指向上海滩，那么暂停播放
If Dir(Pathstr) = "上海滩.MP3" Then Player "Pause """ & Pathstr & """",
"", 0, 0
End Sub
Sub ResumeMp3() '继续播放(从暂停处继续播放)
'如果变量Pathstr指向上海滩，那么继续播放
If Dir(Pathstr) = "上海滩.MP3" Then Player "Resume """ & Pathstr & """",
"", 0, 0
End Sub
步骤3 光标置于过程“OpenMp3”中任意位置，并按【F5】键执行，程序会在D盘中查找“上海滩.MP3”。如果找到，那么立即开始播放音乐，在内存中执行，不显示任何界面。
步骤4 执行过程“PauseMp3”可以将音乐暂停，而执行过程“ResumeMp3”则继续播放，“CloseMp3”用于关闭音乐播放。
原理分析
“winmm.dll”文件的文件名“winmm”其实是Windows Multimedia API的缩写，它是多媒体相关应用程序接口，通过API声明可以调用其内置音乐播放函数。
函数Player的第一参数为“Play”时表示播放音乐文件，必须附带一个音乐文件名。如果是停止播放，那么既可以在参数中使用文件名，表示中断该音乐文件的播放，也可以使用参数“close all”，表示关闭所有音乐。
知识扩展
※ 播放音乐的三种方式 ※
“winmm.dll”文件中还有一个“mciGetDeviceIDA”函数，可以用于判断当前音乐文件是否播放完毕，在连续播放多个音乐文件时将会用到。
也可以利用VBA的“WMPlayer.OCX”控件来播放音乐及视频，并具有可视界面。
还可以使用动态链接库“shell32.dll”中的ShellExecute函数播放音乐。ShellExecute播放音乐的特点是调用系统中默认的播放器，即如果系统中只有“windows media player”时就调用它播放，而安装“千千静听”后它就调用“千千静听”播放。利用它调用邮件程序发送邮件时也是同样的处理方式。以下代码是ShellExecute函数案例：
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Sub aa() ShellExecute 0, "open", "E:\歌曲\天龙八步.MP3", "", "", 1 End Sub
注意
ShellExecute除了调用邮件程序、MP3播放器外，还有其他很多功能。例如，打开包括网上邻居的文件夹、打开任意文件、播放电影、Flash 等。读者可以实际测试它还包括多少其他强大的功能。
疑难49 如何在网上自动搜索与当前单元格同名的歌曲并播放
在单元格中写入歌曲名，然后通过程序自动到网上搜索歌曲并播放，可以实现吗？
解决方案
创建一个IE控件的引用，让IE控件打开百度的MP3音乐搜索网页，并打开“试听”链接进行播放。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Dim oWeb As Object
'获取音乐链接
Sub 查找音乐并播放() '查找名为当前单元格文字的歌曲并播放
If Len(ActiveCell.Text) = 0 Then Exit Sub
Dim 链接 As Object
'创建一个IE控件的实例
Set oWeb = CreateObject("InternetExplorer.Application")
oWeb.Visible = False '隐藏其界面
'打开IE浏览器（调用百度的音乐搜索界面）
oWeb.Navigate "http://mp3.baidu.com/m?f=ms&tn=baidump3&ct=
134217728&lf=&rn=&word= " & ActiveCell.Text & "&lm=-1"
Do Until oWeb.Readystate = 4 ' 检查网页是否加载完毕（4表示完全加载）
DoEvents '转让控制权，以免“软死机”（网页从打开到加载完毕根据网页中的内容多少
有时间差异）
Loop
For Each 链接 In oWeb.Document.Links '循环检查该页面中的所有链接
If 链接.innerText = "试听" Then '如果链接的显示文字是“试听”
oWeb.Navigate 链接.href '打开链接页面，开始播放
GoTo endd '结束程序
End If
Next 链接
MsgBox "找不到该歌曲！" '如果没有找到则提示用户
endd:
End Sub
Sub 关闭() '退出
oWeb.Quit
Set oWeb = Nothing
End Sub
步骤3 返回工作表界面，在A1单元格输入“2002年的第一场雪”。然后选择功能区“开发工具”选项卡，单击“宏”按钮，从弹出的对话框中选择“查找音乐并播放”，1秒到3秒钟后可听到“2002年的第一场雪”歌曲已开始播放。当然不同环境下网速会有差异，将直接影响执行程序到播放歌曲这段时间的长短。
原理分析
※ 利用网页地址索引歌曲并自动播放 ※
百度MP3网“mp3.baidu.com”可以搜索并播放歌曲，而VBA可以引用IE控件来调用该网页，那么使得实现网络搜索MP3就成为可能。重点在于如何找到与当前单元格同名的MP3并播放，通过观察查找歌曲后产生的网页地址可以发现网址中总是包含歌曲名，所以将网址中嵌入当前单元格的字符即可打开该歌曲的搜索页面。
在每首歌曲搜索页面通常都有很多链接，包括歌手名、歌词名、试听和专辑名等，所以利用循环检查每个链接，找到文字为“试听”的链接，再打开该链接的网页即可。
知识扩展
本例中VBA调用网络MP3歌曲播放界面是采用直接找到指定歌曲并自动播放的思路，如果仅仅打开歌曲搜索界面让用户选择或者搜索歌曲则可以换一种思路——创建窗体，并在窗体中添加VBA中的“WebBrowser”控件，利用该控件引用网址即可。
注意
本例是调用网络资源播放MP3，那么只能在本机网络可用的前提下执行过程。