『第
5 楼』:
很久以前做过一个
Option Explicit
'By Shilyx 2006.12.15 oversleep@163.com (2007.3.31 新加打开文件和拷贝到剪贴板功能
Dim fso, ts, target, output, objDialog
Const SpaceToNBSPRate = 1
Const TabToSpace = 8
Const ForWriting = 2
Const ForReading = 1
Const adTypeBinary = 1
If WScript.Arguments.Count < 1 Then
Set objDialog = CreateObject("UserAccounts.CommonDialog")
objDialog.Filter = "All Files|*.*"
objDialog.InitialDir = "."
If objDialog.ShowOpen = 0 Then
WScript.Quit
Else
target = objDialog.FileName
End If
Set objDialog = Nothing
Else
target = WScript.Arguments(0)
End If
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(target) Then
MsgBox "找不到文件" & target, 16, "错误"
WScript.Quit
End If
If Not IsTextFile(target) Then
WScript.echo target & "不是有效的文本文件"
WScript.Quit
End If
GetOutput
If output = target Then WScript.Quit
ChangeFileFormat target, output, SpaceToNBSPRate
If vbYes = MsgBox("输出已经复制到系统剪贴扳，并且保存在" & output & VbCrLf & "现在是否打开输出文件？",vbYesNo,"By Shilyx 2006.12.15") Then
Dim ws
Set ws = WScript.CreateObject("WScript.Shell")
ws.Run "Notepad " & Chr(32) & output & Chr(32)
End If
Function IsTextFile(file)
Dim aso, ch
IsTextFile = True
Set ASO = CreateObject("ADODB.Stream")
aso.Type = adTypeBinary
aso.Open
aso.LoadFromFile file
aso.Position = 0
Do While Not aso.EOS
ch = aso.Read(1)
If ASCB(ch) = 0 Then
IsTextFile = False
Exit Function
End If
Loop
End Function
Sub GetOutput
Dim len1, len2
output = WScript.ScriptFullName
len1 = Len(output)
len2 = Len(fso.GetFileName(output))
output = Left(output, len1 - len2)
output = output + "output.txt"
End Sub
Sub CopyToClipBoard(Text)
Dim objIE
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Navigate("about:blank")
objIE.Document.ParentWindow.ClipboardData.SetData "text", Text
objIE.Quit
End Sub
Sub ChangeFileFormat(input, output, nSpace)
Dim line, Fin, Fout, NewLine, AllNewLines
Set Fin = fso.OpenTextFile(input, ForReading)
Set Fout = fso.CreateTextFile(output, ForWriting)
Do While Not Fin.AtEndOfStream
line = Fin.ReadLine
NewLine = ChangeLine(line, nSpace)
AllNewLines = AllNewLines & vbCrLf & NewLine
Fout.WriteLine(NewLine)
Loop
Fin.Close
Fout.Close
CopyToClipBoard AllNewLines
End Sub
Function ChangeLine(line, nSpace)
Dim SpaceNum
If Replace(line, " ", "") = "" Then
ChangeLine = Chr(38) + "nbsp;"
Exit Function
End If
line = RTrim(line)
SpaceNum = 0
Do While True
If Left(line, 1) = " " Then
SpaceNum = SpaceNum + 1
ElseIf Left(line, 1) = Chr(9) Then
SpaceNum = SpaceNum + TabToSpace
Else
Exit Do
End If
line = Right(line, Len(line) - 1)
Loop
ChangeLine = GetNBSP(SpaceNum * nSpace) & Trim(line)
End Function
Function GetNBSP(SpaceNum)
GetNBSP = Space(SpaceNum)
GetNBSP = Replace(GetNBSP, " ", Chr(38) + "nbsp;")
End Function http://hi.baidu.com/shilyx/blog/ ... 93f802738da5c1.html
|
