strPath = CreateObject("Wscript.Shell").CurrentDirectory
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPath)
set objFiles = objFolder.Files

for Each objFile In objFiles
    If LCase(Right(objFile.Name, 3)) = "xls" Then
        With CreateObject("Adodb.Stream")
            .Charset = "utf-8"    '原来是什么格式？
            .Type = 2
            .Mode = 3
            .Open
            .LoadFromFile objFile.Name
            strRead = .ReadText
            .Close
        End With

        With CreateObject("Adodb.Stream")
            .Charset = "Unicode"
            .Type = 2
            .Mode = 3
            .Open
            .WriteText strRead
            .SaveToFile "Unicode " & objFile.Name, 2
            .Close
        End With
        Msgbox objFile.Name & " 转换完毕。"
    End If
Next
复制代码

Dim XLSFolder, TXTFolder, fso, stm, xl

' 设置项目源文件所在的工作路径
XLSFolder = "D:\my\tables"
' 目标文件夹，必须是已存在的
TXTFolder = "D:\my\tables_trans"

Set fso = CreateObject("Scripting.FileSystemObject")

Set stm = CreateObject("ADODB.Stream")
    stm.Mode = 3
    stm.Type = 2
    stm.Charset = "unicode"
    
Set xl = CreateObject("Excel.Application")
    xl.Visible = False
    
ProcessAllFiles XLSFolder

xl.Quit

WScript.Echo "处理结束。"


'* 遍历文件夹
'******************************
Function ProcessAllFiles(folderspec)        
    Dim fd, fs, f, sfds, sfd
    Set fd = fso.GetFolder(folderspec)
    Set fs = fd.Files
    For Each f in fs
        If UCase(Right(f.Path, 4)) = ".XLS" Then
            ProcessOneFile f.Path
        End If
    Next
    Set sfds = fd.SubFolders
    For Each sfd in sfds
        ProcessAllFiles sfd.Path
    Next
End Function


'* 处理一个文件，反悔错误代码
'********************************
Function ProcessOneFile(filespec)
    On Error Resume Next
    Dim iResult, newPath
    iResult = 0
    newPath = GenerateNewPath(filespec, XLSFolder, TXTFolder)
    ' 处理一个文件
    '-------- start ----------
    Dim wb, ur, i, j, strAll
    ' 打开此文件，不更新链接，只读
    Set wb = xl.Workbooks.Open(filespec, 0, True)
    Set ur  = wb.WorkSheets(1).UsedRange
    For i = 1 To ur.Rows.Count
        For j = 1 To ur.Columns.Count
            If j > 1 Then
                strAll = strAll & vbTab
            ElseIf i > 1 Then
                strAll = strAll & vbCrLf
            End If
            strAll = strAll & ur.Cells(i, j).Text
        Next
    Next
    wb.Close
    stm.Open
    stm.WriteText strAll
    stm.SaveToFile newPath & ".txt"
    stm.Close
    '---------  end  ---------
    If Err.Number <> 0 Then
        iResult = Err.Number
        Err.Clear
    End If
    On Error Goto 0
End Function


'* 生成一个结构相同的新路径
'**********************************
Function GenerateNewPath(dpnx, dp1, dp2)
    Dim absDP1, absDP2, starPos, pNames, dpnx2, i
    absDP1 = fso.GetFolder(dp1).Path
    absDP2 = fso.GetFolder(dp2).Path
    pNames = Split(dpnx, "\")
    starPos = UBound(Split(absDP1, "\")) + 1
    For i = starPos To UBound(pNames) - 1
        absDP2 = fso.BuildPath(absDP2, pNames(i))
        If Not fso.FolderExists(absDP2) Then fso.CreateFolder absDP2
    Next
    dpnx2 = fso.BuildPath(absDP2, pNames(UBound(pNames)))
    GenerateNewPath = dpnx2
End Function
复制代码