[问题求助] VBS实现将多个xls文件批量转换成unicode文本

hacker85

RT！

对于一个有多个xls文件的文件夹，如果通过一个VBS脚本实现对每个xls文件进行“另存为unicode文本”的操作？？

注：只对工作薄中的sheet1工作表进行操作即可。

czjt1234

转换当前目录下所有.xls
"1.xls"  转换为 "Unicode 1.xls"
就是不清楚原来是什么格式

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
复制代码

czjt1234

哦，不对，不能直接读取.xls文件

要读取里面的工作表的内容

excel对象还没学习过，帮不了你

hacker85

回复 2# czjt1234


    1、不需要管xls文件是什么格式，只需要将其转换成unicode文本文件就可以了，因为我们实现的是“另存”功能。

   2、这些xls文件分散在不同的多级目录下，那么对于多级目录来说，又如何更改vbs的代码呢？

hacker85

回复 3# czjt1234


    呵，你已经尽力了，3Q

czjt1234

不能直接读取.xls文件

不是文本流的数据

zz100001

这两天刚好移植一个项目要处理所有文件内容，写了个脚本。改了下变成搞excel的，你可以试试

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
复制代码