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
