broly

'By Broly 
'From http://bbs.bathome.net/

Dim fso,f,choice
Dim xlsPath,txtPath,strText,target

xlsPath = "d:\myExcel.xls"
txtPath = "d:\myText.txt"
target = "d:\tatget.txt"

choice = InputBox("1.TXT -> Excel" & vbCrLf & "2.Excel -> TXT","请选择")

Set fso = CreateObject("Scripting.FileSystemObject")

Select Case choice
	Case 1:
		If Not fso.FileExists(xlsPath) Then CreateXlsFile(xlsPath)
		strText = GetText(txtPath)
		WriteExcel xlsPath,strText
		MsgBox "Succeed."
		
	Case 2:
		Set f = fso.OpenTextFile(target,8,True)
		f.Write GetExcelInfo(xlsPath)
		f.Close
		Set f = Nothing
		MsgBox "Succeed."
		
	Case Else:
		MsgBox "Wrong choice."
		
End Select

Set fso = Nothing


Function CreateXlsFile(Path)
	Dim objExcel
	Set objExcel = CreateObject("Excel.Application")
	objExcel.Workbooks.Add()
	objExcel.ActiveWorkbook.SaveAs Path
	objExcel.Quit
	Set objExcel = Nothing
End Function

Function GetText(Path)
	Set f = fso.OpenTextFile(Path,1,False)
	If Not f.AtEndOfStream Then
		GetText = f.ReadAll
	End If
	f.Close
	Set f = Nothing
End Function

Function WriteExcel(Path,strText)
	Dim oExcel,oWorkBooks,oWorkSheet
	Dim arr,i,arr2
	
	arr = Split(strText,vbCrLf,-1,1)
	Set oExcel = CreateObject("Excel.Application")
	Set oWorkBooks = oExcel.Workbooks.Open(Path)
	Set oWorkSheet = oWorkBooks.Sheets(1)
	
	oWorkSheet.Activate
	oWorkSheet.Columns(1).ColumnWidth = 45
	oWorkSheet.Columns(2).ColumnWidth = 35
	For i = 0 To UBound(arr)
		arr2 = Split(arr(i),":",-1,1)
		ReDim Preserve arr2(2)
		If InStr(arr2(0),"-----") = 0 And _
			arr2(0) <> "" _
		Then
			oWorkSheet.Cells(i+1,1).Value = arr2(0) & ":"
		Else 
			oWorkSheet.Cells(i+1,1).Value = arr2(0)
		End If
		oWorkSheet.Cells(i+1,2).Value = arr2(1)
	Next
	
	oWorkBooks.Save
	oWorkBooks.Close
	oExcel.Quit
	
	Set oExcel = Nothing
	Set oWorkBooks = Nothing 
	Set oWorkSheet = Nothing
End Function

Function GetExcelInfo(Path)
	Dim oExcel,oWorkBooks,oWorkSheet
	Dim i,strText
	
	Set oExcel = CreateObject("Excel.Application")
	Set oWorkBooks = oExcel.Workbooks.Open(Path)
	Set oWorkSheet = oWorkBooks.Sheets(1)
	
	oWorkSheet.Activate
	i = 1
	Do While oWorkSheet.Cells(i,1).Value <> ""
		strText = strText & vbCrLf _
			& oWorkSheet.Cells(i,1).Value _
			& oWorkSheet.Cells(i,2).Value
		i = i + 1
	Loop
	
	oWorkBooks.Close
	oExcel.Quit
	
	GetExcelInfo = strText
	
	Set oExcel = Nothing
	Set oWorkBooks = Nothing 
	Set oWorkSheet = Nothing
End Function
复制代码