VBS实现将多个xls文件批量转换成unicode文本

hacker85 · 发表于 2012-12-12 09:25:06

RT！

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

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

czjt1234 · 发表于 2012-12-13 10:29:55

本帖最后由 czjt1234 于 2012-12-13 10:40 编辑

转换当前目录下所有.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 · 发表于 2012-12-13 10:44:45

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

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

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

hacker85 · 发表于 2012-12-13 13:53:55

回复 2# czjt1234

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

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

hacker85 · 发表于 2012-12-13 13:54:26

回复 3# czjt1234

呵，你已经尽力了，3Q

czjt1234 · 发表于 2012-12-14 09:22:25

不能直接读取.xls文件

不是文本流的数据

zz100001 · 发表于 2012-12-14 18:05:32

这两天刚好移植一个项目要处理所有文件内容，写了个脚本。改了下变成搞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

复制代码

		自动登录	找回密码
密码			注册

[新手上路]批处理新手入门导读	[视频教程]批处理基础视频教程	[视频教程]VBS基础视频教程	[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动	[批处理精品]CMD命令50条不能说的秘密	[在线下载]第三方命令行工具	[在线帮助]VBScript / JScript 在线参考

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

浏览过的版块