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

MsgBox CreateObject("Scripting.FileSystemObject").FileExists("D:\生产表\单价表.xlsx")

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

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

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

  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

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

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

Sub 打开网上邻居的文件夹()
Shell "explorer.exe \\192.168.1.2\andysky\", vbMaximizedFocus
End Sub

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

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

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