' 获取所有参数，请拖放所有Excel文件到本脚本文件(也可以将本脚本加入发送到菜单)
For Each objArg In WScript.Arguments
  Excel2Txt objArg
Next

Function Excel2Txt(FilePath)

  On Error Resume Next
  Set fso = CreateObject("Scripting.Filesystemobject")
  If Not fso.FileExists(FilePath) Then Exit Function
  
  ' 创建 Excel 对象
  Set objExcel = CreateObject("Excel.Application")
  If Not Err.Number = 0 Then
    Msgbox "错误：无法创建 Excel 对象，你可能没有安装 Excel 。"
    Exit Function
  End If

  If Not objExcel.application.version >= 12.0 Then
    Msgbox "警告：请使用 Office 2007 以上版本。"
  End If

  ' 隐藏运行，屏蔽提示
  objExcel.Visible = False
  objExcel.DisplayAlerts = False
  
  ' 打开 excel 文件，遍历所有工作表，保存为 Unicode txt
  Const xlUnicodeText = 42
  Set objWorkbook = objExcel.WorkBooks.Open(FilePath)
  For Each objWorkSheet In objWorkbook.Worksheets
	' 另存为 UnicodeText，改为其他格式，自行录制宏参考
    objWorkSheet.SaveAs FilePath & "_" & objWorkSheet.Name & ".txt", _
      xlUnicodeText, False
  Next
      
  ' 退出
  objExcel.Quit
  If Not Err.Number = 0 Then Excel2Txt = True
End Function
复制代码

Main
Sub Main()
  Dim strPath, arrPath
  strPath = BrowseForFolder("请选择 Excel 文件路径：")
  If strPath = "" Then Exit Sub
  arrPath = ScanFolder(strPath)
  For Each strPath In arrPath
    If LCase(Right(strPath,4))=".xlsx" Or LCase(Right(strPath,5))=".xlsx" Then
      Excel2Txt strPath
    End If
  Next
End Sub

Function Excel2Txt(FilePath)

  On Error Resume Next
  Set fso = CreateObject("Scripting.Filesystemobject")
  If Not fso.FileExists(FilePath) Then Exit Function
  
  ' 创建 Excel 对象
  Set objExcel = CreateObject("Excel.Application")
  If Not Err.Number = 0 Then
    Msgbox "错误：无法创建 Excel 对象，你可能没有安装 Excel 。"
    Exit Function
  End If

  If Not objExcel.application.version >= 12.0 Then
    Msgbox "警告：请使用 Office 2007 以上版本。"
  End If

  ' 隐藏运行，屏蔽提示
  objExcel.Visible = False
  objExcel.DisplayAlerts = False
  
  ' 打开 excel 文件，遍历所有工作表，保存为 Unicode txt
  Const xlUnicodeText = 42
  Set objWorkbook = objExcel.WorkBooks.Open(FilePath)
  For Each objWorkSheet In objWorkbook.Worksheets
        ' 另存为 UnicodeText，改为其他格式，自行录制宏参考
    objWorkSheet.SaveAs FilePath & "_" & objWorkSheet.Name & ".txt", _
      xlUnicodeText, False
  Next
      
  ' 退出
  objExcel.Quit
  If Not Err.Number = 0 Then Excel2Txt = True
End Function


Function BrowseForFolder(ByVal strTips)
  Dim objFolder
  Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
End Function


Function ScanFolder(ByVal strPath)
    Dim arr()
    ReDim Preserve arr(0)
    Call SCAN_FOLDER(arr, strPath)
    ReDim Preserve arr(UBound(arr) - 1)
    ScanFolder = arr
End Function
Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
    On Error Resume Next
    Dim fso, objItems, objFile, objFolder
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objItems = fso.GetFolder(folderSpec)
    If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
    If (Not fso.FolderExists(folderSpec)) Then Exit Function
    For Each objFile In objItems.Files
        arr(UBound(arr)) = objFile.Path
        ReDim Preserve arr(UBound(arr) + 1)
    Next
    For Each objFolder In objItems.subfolders
        Call SCAN_FOLDER(arr, objFolder.Path)
    Next
    arr(UBound(arr)) = folderSpec
    ReDim Preserve arr(UBound(arr) + 1)
End Function
复制代码