『第
4 楼』:
不能解决的问题：
1. 不能按照你给的方案命名导出的文件，因为不确定有几张表，你在命令行无法给出参数；
我把你的第二个参数改成指定导出路径，文本文件的命名是 "输出路径\EXCEL文件名.表名.txt"
2. 经试验发现，合并的单元格被识别成 最左上的单元格包含所有数据，其他单元格数据为空。
另：
不给输出路径则默认当前工作路径；
默认不导出空的表，如果有特殊需求可以修改 VBS 源代码里面的那个参数，有说明。
'***************************************************
'*
'* 特殊需求的EXCEL导出文本工具 xzt.vbs
'*
'* (P)&(C) 2010 『据说是李先生』
'* qinchun36 CN-DOS.net
'*
'* xzt.vbs EXCEL文件名 [输出路径]
'* xzt.vbs [drive:][path]filename [drive:][path]
'*
'* 输出文件为 输出路径\EXCEL文件名.表名.txt
'*
'***************************************************
On Error Resume Next
Set fso = WScript.Createobject("Scripting.FileSystemObject")
' 获取文件的全路径，因为 EXCEL 需要全路径
fileInputName = WScript.Arguments(0)
fileFullName = fso.GetFile(fileInputName).Path
' 如果未指定输出路径则默认为当前工作路径；
' 如果指定的路径不纯在则尝试创建，但仅在它的父目录存在时能成功
fileOutputFolder = fso.GetFolder(".").Path
If WScript.Arguments.Count > 1 Then
fileOutputFolder = WScript.Arguments(1)
If Not fso.FolderExists(fileOutputFolder) Then fso.CreateFolder fileOutputFolder
End If
'fileOutputFolder = fso.GetFile(fileInputName).ParentFolder
' 输出文件路径，经过我考虑决定去掉，因为你不知道有几张表。
'fileOutputName = WScript.Arguments(1)
'Set f = fso.CreateTextFile(fileOutputName, True, True)
' 创建 Excel.Application 对象
Set excel = WScript.CreateObject("Excel.Application")
'===============================================
' 上面把所有必需的“基础设施”都搞一遍，
' 每个都是致命的，因此累积错误，如果有的话就退出
'===============================================
If Err.Number <> 0 Then
WScript.Echo "因参数错误或没安装EXCEL，程序退出：" & vbCrLf & vbCrLf & Err.Description
Err.Clear
excel.Quit
WScript.Quit
End If
' “打开EXCEL程序”
Set wbs = excel.Application.Workbooks
' 打开一个 EXCEL 文件
wbs.Open(fileFullName)
' 得到这个文件
Set wb = wbs.Item(1)
' 得到所有的表
Set shts = wb.Sheets
' 初始化提示信息
msg = "处理的文件是" & vbCrLf & fileFullName & vbCrLf & vbCrLf & "共有 " & shts.Count & " 张表，分别导出为" & vbCrLf
' 干活， False 表示不导出空的表
DealWithAllSheets shts, False
' 退出
wb.Close
wbs.Close
excel.Quit
MsgBox msg, 4160, "完成"
WScript.Quit
'******************************** 下面都是功能函数了 ****************************************
' 获取一张工作表已经使用的数据范围相关信息
' 返回数组 {已使用行数, 已使用列数, 最小行号, 最大行号, 最小列号, 最大列号}
' WorksheetObject.UsedRange 是此工作表已经使用的区域
' .Rows 是它所有的行，.Columns是所有的列
' .Count 是总数，.Row 是行号，.Column 是列号
'-----------------------------------------------
Function GetUsedRangeXY(WorksheetObject)
Dim x, y, x0, x1, y0, y1
y = WorksheetObject.UsedRange.Rows.Count
If y = 0 Then
y0 = 0
y1 = 0
Else
y0 = WorksheetObject.UsedRange.Rows(1).Row
For Each rw In WorksheetObject.UsedRange.Rows
y1 = rw.Row
Next
End If
x = WorksheetObject.UsedRange.Columns.Count
If x = 0 Then
x0 = 0
x1 = 0
Else
x0 = WorksheetObject.UsedRange.Columns(1).Column
For Each col In WorksheetObject.UsedRange.Columns
x1 = col.Column
Next
End If
GetUsedRangeXY = Array(y, x, y0, y1, x0, x1)
End Function
' 遍历并处理每张表
' 参数 allSheets 是一个 WorkSheets 对象
' bOutputNullSheet 控制是否输出空的表单
' True 为输出，False 为不输出
'-------------------------------------------------
Sub DealWithAllSheets(allSheets, bOutputNullSheet)
Dim oneSheet()
For Each sht in allSheets
msg = msg & vbCrLf & sht.Name & " ==> "
' 一张表的信息
temp = GetUsedRangeXY(sht)
ix = temp(3) - 1
iy = temp(5) - 1
' 装一个表的数据
ReDim oneSheet(ix, iy)
' 所有的表格
Set cls = sht.Cells
For i = 0 To ix
For j = 0 To iy
val = cls((i + 1), (j + 1)).Value
If val = "" Then val = "#"
oneSheet(i,j) = val
Next
Next
If ix + iy > 0 Or bOutputNullSheet Then
OutPutOneSheet oneSheet, sht.Name
Else
msg = msg & "是空的，未导出。" & vbCrLf
End If
Next
End Sub
' 比较整洁地输出一张表的内容
'---------------------------
Sub OutPutOneSheet(Arraymxn, sheetName)
' 这里使用 Unicode 编码输出，以保持最大兼容性
' 你也可以将第三个参数 True 改成 False 或者去掉以使用 ASCII 编码
Set f = fso.CreateTextFile(fileOutputFolder & "\" & wb.Name & "." & sheetName & ".txt", True, True)
For j = 0 To UBound(Arraymxn, 2)
l = 0
For i = 0 To UBound(Arraymxn, 1)
li = getLenInTabs(Arraymxn(i, j))
If li > l Then l = li
Next
For i = 0 To UBound(Arraymxn, 1)
lx = l - getLenInTabs(Arraymxn(i, j))
For k = 0 To lx
Arraymxn(i, j) = Arraymxn(i, j) & vbTab
Next
Next
Next
For i = 0 To UBound(Arraymxn, 1)
For j = 0 To UBound(Arraymxn, 2)
f.Write Arraymxn(i, j)
Next
f.Write vbCrLf
Next
f.Close
msg = msg & fso.GetFile(fileOutputFolder & "\" & wb.Name & "." & sheetName & ".txt").Path & vbCrLf
End Sub
' 粗略得到一个字符串看起来的长度(上限)占用的最小的制表符个数
'------------------------------
Function getLenInTabs(sString)
Dim str, ch, l
str = sString
l = Len(str)
While Len(str) > 0
ch = Left(str, 1)
If AscW(ch) > 255 Or AscW(ch) < 0 Then l = l + 1
str = Mid(str, 2)
WEnd
l = (Int)(l / 8) + 1
getLenInTabs = l
End Function
|
