Set oShell = CreateObject("Shell.Application")
Set oDir = oShell.BrowseForFolder(0,"选择目录",0)
For Each x In oDir.Items
If LCase(Right(x.Path,4)) = ".xls" Then
XLS2TXT x.Path
End If
Next
'****************************************************************************************
'开始转换
'****************************************************************************************
Sub XLS2TXT(strFileName)
'若有装Excel只需
'oExcel.ActiveWorkbook.SaveAs strFileName ".txt", -4158
'下面的方法适合没有装Office的系统
On Error Resume Next
Dim oConn,oAdox,oRecordSet
Set oConn = CreateObject("Adodb.Connection")
Set oAdox = CreateObject("Adox.Catalog")
sConn = "Provider = Microsoft.Jet.Oledb.4.0;" _
"Data Source = " strFileName ";" _
"Extended Properties = ""Excel 8.0; HDR=No"";"
sSQL = "Select * From "
oConn.Open sConn
if Err Then
Msgbox "错误代码:" Err.Number VbCrLf Err.Description
Err.Clear
else
oAdox.ActiveConnection = oConn
sSQL = sSQL "[" oAdox.Tables(0).Name "]" '为了简便，只处理第一个工作表
Set oRecordSet = oConn.Execute(sSQL)
if Err Then
Msgbox "错误代码:" Err.Number VbCrLf Err.Description
Err.Clear
else
Write strFileName ".txt",oRecordSet.GetString
end if
end If
oRecordSet.Close
oConn.Close
Set oRecordSet = Nothing
Set oAdox = Nothing
Set oConn = Nothing
End Sub
'****************************************************************************************
'写入文件，同名覆盖，无则创建
'****************************************************************************************
Sub Write(strName,str)
Dim oFSO,oFile
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFile = oFSO.OpenTextFile(strName,2,True) '不存在则创建,强制覆盖
oFile.Write str
oFile.Close
Set oFile = Nothing
Set oFSO = Nothing
End Sub