vbs网页编辑器效率有点低,请高手帮忙看一下. - 中国DOS联盟论坛

两个主要的问题:
1 是否可以将选择内容扩展到段落?也许这样可以提高效率.
2 编辑键捕获及过滤: 编辑操作有问题,选中一段后,按退格键应该是全部删除的,可是现在却只删除了一个字符.

div.hta


<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML>
<hta:application>
<HEAD>
<TITLE> Editor </TITLE>
<META NAME="Generator" CONTENT="EditPlus">
<META NAME="Author" CONTENT="sonic_andy">
<META NAME="Keywords" CONTENT="editor">
<META NAME="Description" CONTENT="a vbscript editor">
  
<style>
	p {padding:0 0 0 0; margin:0 0 0 0;}
	.editor {border:double; width:100%; height:60%; overflow:scroll;}
	.SCRIPTS {color:red}
	.QUOTATION {color:#800080}
	.COMMENT {color:green}
	.KEYWORD1 {color:blue}
	.KEYWORD2 {color:red}
	.KEYWORD3 {color:blue}
	.KEYWORD4 {color:blue}
	.KEYWORD5 {color:blue}
	.PREFIX_KEYWORD {color:brown}
	.SUFFIX_KEYWORD {color:brown}
	.DIGIT {color:brown}
</style>
<script language="vbscript" src="syntax.vbs"></script>
<script language="vbscript">
Set oSC = New SyntaxColor
Set reg = new regexp
reg.ignorecase = True
reg.global = True
Set fso = CreateObject("scripting.filesystemobject")

Sub writedebugfile(str2write)
	Set file = fso.opentextfile("debug.txt",2,true)
	Call file.write(str2write)
	Call file.close()
	Set file = Nothing 
End Sub

Sub edit()
	If Not isValidKey() Then Exit Sub
	
	' 得到并保存当前选中的位置
	Set range = Document.selection.createrange()
	x = range.offsetleft
	y = range.offsettop
	l = Len(range.text)

	' 过滤操作
	str = Document.all.editor.innerhtml

	reg.pattern="<br>"
	str = reg.Replace(str,"<br>" & vbcrlf)

	reg.pattern="</?span*>"
	str = reg.Replace(str,"")

'	Document.all.status.value = str
'	MsgBox "wait"

'	oSC.infpath = "D:\CHDOC\vbstxclass"
'	osc.stxpath = "D:\CHDOC\vbstxclass\stx"
	Call osc.get_syntax("vbs")
	str = osc.analyze_syntax(str)

'	reg.pattern = vbcr
'	str = reg.Replace(str,"<br>" & vbcrlf)

	Document.all.editor.innerhtml = str

	' 恢复当前位置
	Call range.movetoelementtext(Document.all.editor)
	Call range.movetopoint(x,y)
	Call range.moveend("character",l)

'	Call range.collapse(false)
'	Call range.expand("word")
	Call range.Select()

	Document.all.status.value = Document.all.editor.innerhtml
End Sub

Function isValidKey()
	Select Case Window.event.keycode
	Case 37,38,39,40	' Left,Up,Right,Down
		isValidKey = False
		Exit Function
	Case 33,34,35,36	' Home,End,PgUp,PgDn
		isValidKey = False
		Exit Function
	Case 16,17		' Shift,Ctrl
		isValidKey = False
		Exit Function
	End Select
	If Window.event.altkey Then ' 按下Alt
		isValidKey = False
		Exit Function
	End If
	If Window.event.ctrlkey Then ' 按下Ctrl
		isValidKey = False
		Exit Function
	End If
	isValidKey = True
End Function

Sub filterkey()
	If Not isValidKey() Then Exit Sub

	Set range = Document.selection.createrange()

	' 处理tab键
	If Window.event.keycode=Asc(vbtab) Then
		Window.event.returnvalue = False
		range.text = vbtab
	End If 

	Call range.collapse(false)
	Call range.Select()
End Sub

Sub syc()
	Document.all.status.value = Document.all.editor.innerhtml
End Sub
</script>
</HEAD>

<BODY>
<div id="editor" contenteditable class="editor" onkeydown="filterkey" onkeyup="edit"></div>
<br>
<textarea id="status" cols="120" rows="10"></textarea>
<br>
<input type="button" value="同步" onclick="syc">
</BODY>
</hta:application>
</HTML>

syntax.vbs


Option Explicit

' 语法着色类 sonic_andy
'Set test = New SyntaxColor
'Call test.get_syntax("vbs")
'msgbox test.analyze_syntax("asdfasdf")

class SyntaxColor
	Private quotation_span      '引用标记
	Private comment_span        '注释标记
	Private script_span         '脚本标记
	Private keyword_span        '关键字标记
	Private prefix_keyword_span '前缀关键字标记
	Private suffix_keyword_span '后缀关键字标记
	Private digit_span          '数字标记
	Private span_end            '结束标记

	Private setting             '当前
	Private keyword()           '关键字字符串
	Private prefix              '前缀
	Private suffix              '后缀
	Private html_instance       'a html instance
	Private mtabwidth           'tab宽度
	Public infpath              'inf文件路径
	Public stxpath              'stx文件路径

	Private fso                 '文件系统对象
	Private reg                 '正则表达式对象

	Private Sub Class_Initialize()
		quotation_span = "<SPAN CLASS=QUOTATION>"
		comment_span = "<SPAN CLASS=COMMENT>"
		script_span = "<SPAN CLASS=SCRIPTS>"
		prefix_keyword_span = "<SPAN CLASS=PREFIX_KEYWORD>"
		suffix_keyword_span = "<SPAN CLASS=SUFFIX_KEYWORD>"
		digit_span = "<SPAN CLASS=DIGIT>"
		keyword_span = Array( _
			"<SPAN CLASS=KEYWORD1>", _
			"<SPAN CLASS=KEYWORD2>", _
			"<SPAN CLASS=KEYWORD3>", _
			"<SPAN CLASS=KEYWORD4>", _
			"<SPAN CLASS=KEYWORD5>")
		span_end = "</SPAN>"
		
		Set setting = CreateObject("scripting.dictionary")
		setting.CompareMode = vbTextCompare
		ReDim keyword(0)
		Set fso = CreateObject("scripting.filesystemobject")
		Set reg = New RegExp
		reg.IgnoreCase = True
		reg.Global = True
		infpath = ".\"
		stxpath = ".\stx\"
		mtabwidth = 4
	End Sub

	' 从"ext.inf"文件中读取扩展名和分析信息文件的对应关系,
	' 并且调用get_info函数得到语法相关信息数组.
	'
	' @param string ext 需要分析内容的扩展名
	Public Function get_syntax(ext)
		Dim file        ' 文件流对象
		Dim configure   ' 文件内容
		Dim lines       ' 被换行分隔的内容数组
		Dim arr         ' 每一行中,被等号分隔的内容
		Dim i
		
		'得到扩展名和相关文件名配置文件的内容
		Set file = fso.OpenTextFile(fso.BuildPath(infpath, "ext.inf"), 1) 'vbide
		configure = file.ReadAll
		Call file.Close

		'将内容分割到数组
		lines = Split(configure, vbCrLf)
		For i = LBound(lines) To UBound(lines)
			'先用等号分割将字符串转换为数组array
			arr = Split(lines(i), "=")
			'查找"扩展名;"是否在字符串array中
			If InStr(arr(1), ext & ";") > 0 Then
				Call get_info(arr(0))
				get_syntax = True
			End If
		Next
		get_syntax = False
	End Function

	' 从语法文件中读取语法信息,并且将它存贮到信息数组中
	'
	' @param string filename 语法信息文件名
	Private Function get_info(filename)
		Dim file        ' 文件流对象
		Dim sfile       ' 文件内容
		Dim arr         ' 被\n#分隔的内容
		Dim i
		
		'读取语法文件内容
		Set file = fso.OpenTextFile(fso.BuildPath(stxpath, filename), 1) ' vbide
		sfile = file.ReadAll
		Call file.Close
		'清除行首的注释
		reg.Pattern = "(\n*;*\n)"
		sfile = reg.Replace(sfile, vbCrLf)
		'清除多余的空行
		reg.Pattern = "(+)"
		sfile = reg.Replace(sfile, vbCrLf)
		'用井号将内容分割为数组
		arr = Split(sfile, vbCrLf & "#")
		For i = LBound(arr) To UBound(arr)
			If arr(i) <> "" Then
				Dim pos     ' 等号的位置
				Dim name    ' 等号前的名称
				Dim value   ' 等号后的值
				
				pos = InStr(arr(i), "=")
				name = Mid(arr(i), 1, pos - 1)
				name = Replace(name, "#", "")
				value = Mid(arr(i), pos + 1)
				
				If InStr(name, "KEYWORD") = 1 Then '名称是关键字（keyword）
					Dim temp ' 临时字符串
					
					temp = Mid(value, InStr(value, vbCrLf)) & vbCrLf
					keyword(UBound(keyword)) = temp
					ReDim Preserve keyword(UBound(keyword) + 1)
				Else
					value = Replace(value, vbCr, "")
					value = Replace(value, vbLf, "")

					If name = "PREFIX" Then
						prefix = prefix & value
					ElseIf name = "SUFFIX" Then
						suffix = suffix & value
					ElseIf name = "DELIMITER" Then
						setting(name) = value & vbCrLf & vbTab & " "
					ElseIf name <> "" And value <> "" Then '若名称不为空,去掉回车加入数组
						setting(name) = Replace(value, vbCrLf, "")
					End If
				End If
			End If
		Next
		'创建并设置本类的html实例
		If ((isOptionEnable("HTML_EMBEDDED")) And setting("HTML_EMBEDDED") = "y") Then
			Set html_instance = New SyntaxColor
			html_instance.get_syntax ("html")
			html_instance.set_tabwidth (mtabwidth)
		 End If
	End Function

	' 将字符串中的tab键转换为空格，并且将结果字符串作为html编码返回
	' 该函数作为引用、注释等特殊情况的处理函数被analyze_syntax函数调用。
	'
	' @param string str 源字符串
	' @param int linepos 当前行的位置
	' @param int mtabwidth tab键的宽度
	' @return 结果字符串
	Private Function converttab(str, linepos)
		Dim dest    ' 目标字符串
		Dim i
		Dim ch      ' 第i个字符
		Dim offset  ' 小于于设定tab宽度的行偏移量
		
		dest = ""
		For i = 1 To Len(str)
			ch = Mid(str, i, 1)
			If (ch = "\t") Then
				offset = mtabwidth - linepos Mod mtabwidth
				dest = dest & Space(offset)
				linepos = linepos + offset
			Else
				dest = dest & ch
				linepos = linepos + 1
			End If
			If (ch = "\n") Then
				linepos = 0
			End If
		Next
		converttab = txt2htm(dest)
	End Function

	Private Function txt2htm(str)
		txt2htm = str
		txt2htm = Replace(txt2htm, "", "")
	End Function

	' 设置tab宽度
	'
	' @param int mtabwidth
	Public Property Let tabwidth(ntab)
		mtabwidth = ntab
		If ((isOptionEnable("HTML_EMBEDDED")) And setting("HTML_EMBEDDED") = "y") Then
			html_instance.set_tabwidth (mtabwidth)
		End If
	End Property

	Public Property Get tabwidth()
		tabwidth = mtabwidth
	End Property


	' 外部使用，语法着色功能函数
	'
	' @param string source
	Public Function analyze_syntax(source)
		Dim dest    ' 目标字符串
		Dim i
		
		
		dest = ""
		If ((isOptionEnable("HTML_EMBEDDED")) And setting("HTML_EMBEDDED") = "y") Then
			i = 0
			While (True)
				Dim slen    ' 作用域长度
				
				slen = InStr(i, source, setting("SCRIPT_BEGIN")) - i
				If (slen >= 0) Then
					dest = dest & html_instance.private_analyze(Mid(source, i, slen))
					i = i + slen
					slen = InStr(i, source, setting("SCRIPT_END")) - i + Len(setting("SCRIPT_END"))
					If (slen > 0) Then
						dest = dest & private_analyze(Mid(source, i, slen))
						i = i + slen
					End If
				Else
					dest = dest & html_instance.private_analyze(Mid(source, i))
					analyze_syntax = dest
					Exit Function
				End If
			Wend
		Else
			analyze_syntax = private_analyze(source)
		End If
	End Function

	Private Function isOptionEnable(name)
		If setting.Exists(name) Then
			If setting(name) <> "" Then
				isOptionEnable = True
				Exit Function
			End If
		End If
		isOptionEnable = False
	End Function

	' 分析词法,并着色(内部使用).
	'
	' @param string source 源字符串
	' @param int mtabwidth tab的宽度
	' @return string 着色后的字符串
	Private Function private_analyze(source)
		Dim dest: dest = "" ' 目标字符串
		Dim ch: ch = ""     ' 当前字符
		Dim buffer: buffer = "" ' 缓冲区
		Dim linepos: linepos = 0 '行计数
		Dim offset
		Dim slen
		Dim i
		
		Dim CompareMode
		If isOptionEnable("CASE") And setting("CASE") = "y" Then
			reg.IgnoreCase = False
		Else
			reg.IgnoreCase = True
		End If
		
		'去掉源字符串的反斜杠
		'source = stripslashes(source)
		For i = 1 To Len(source)
			ch = Mid(source, i, 1)
			If (InStr(setting("DELIMITER"), ch) > 0) Then
				'将缓冲区中字符串的长度计算加入行位置变量
				linepos = linepos + Len(buffer)
				'缓冲区不为空的话就分析缓冲区内容是否是关键字
				If (buffer <> "") Then
					Dim j
					For j = 0 To UBound(keyword)
						reg.Pattern = "\b" & buffer & "\b"
						If (reg.Test(keyword(j))) Then
							dest = dest & keyword_span(j) & txt2htm(buffer) & span_end
							buffer = ""
							Exit For
						End If
					Next
				End If
				'缓冲区不为空的话就分析缓冲区内容是否是前缀关键字/后缀关键字,并检查是否是数字
				If buffer <> "" Then
					If (Not IsEmpty(prefix) And InStr(prefix, Mid(buffer, 1, 1)) > 0) Then
						dest = dest & prefix_keyword_span & txt2htm(buffer) & span_end
						buffer = ""
					ElseIf (Not IsEmpty(suffix) And InStr(suffix, Mid(buffer, Len(buffer), 1)) > 0) Then
						dest = dest & suffix_keyword_span & txt2htm(buffer) & span_end
						buffer = ""
					ElseIf ((isOptionEnable("NUMBER_PATTERN")) And _
								setting("NUMBER_PATTERN") = "cpp" And IsNumeric(buffer)) Then
						dest = dest & digit_span & txt2htm(buffer) & span_end
						buffer = ""
					End If
				End If
				'如果缓冲区还不为空，就输出缓冲区
				If buffer <> "" Then
					dest = dest & txt2htm(buffer)
					buffer = ""
				End If
				
				'开始判断分隔符是否是有意义的字符
				If ch = vbLf Then
					offset = mtabwidth - linepos Mod mtabwidth
					dest = dest & txt2htm(Space(offset))
					linepos = linepos + offset
				ElseIf isEqual("LINECOMMENT", source, i) Then
					dest = dest & comment_span
					slen = InStr(i, source, vbCrLf) - i
					If slen > 0 Then
						dest = dest & converttab(Mid(source, i, slen), linepos)
						i = i + slen - 1
					Else
						dest = dest & converttab(Mid(source, i, Len(source) - i), linepos)
						i = Len(source)
					End If
					dest = dest & span_end
				ElseIf isEqual("LINECOMMENT2", source, i) Then
					dest = dest & comment_span
					slen = InStr(i, source, vbCrLf) - i
					If (slen > 0) Then
						dest = dest & converttab(Mid(source, i, slen), linepos)
						i = i + slen - 1
					Else
						dest = dest & converttab(Mid(source, i, Len(source) - i), linepos)
						i = Len(source)
					End If
					dest = dest & span_end
				ElseIf isEqual("COMMENTON", source, i) Then
					dest = dest & comment_span
					slen = InStr(i + 1, source, setting("COMMENTOFF")) - i + Len(setting("COMMENTOFF"))
					If slen > 0 Then
						dest = dest & converttab(Mid(source, i, slen), linepos)
						i = i + slen - 1
					Else
						dest = dest & converttab(Mid(source, i, Len(source) - i), linepos)
						i = Len(source)
					End If
					dest = dest & span_end
				ElseIf isEqual("COMMENTON2", source, i) Then
					dest = dest & comment_span
					slen = InStr(i + 1, source, setting("COMMENTOFF2")) - i + Len(setting("COMMENTOFF2"))
					If slen > 0 Then
						dest = dest & converttab(Mid(source, i, slen), linepos)
						i = i + slen - 1
					Else
						dest = dest & converttab(Mid(source, i, Len(source) - i), linepos)
						i = Len(source)
					End If
					dest = dest & span_end
				ElseIf isEqual("QUOTATION1", source, i) Then
					dest = dest & quotation_span
					slen = InStr(i + 1, source, setting("QUOTATION1")) - i + Len(setting("QUOTATION1"))
					If slen > 0 Then
						dest = dest & converttab(Mid(source, i, slen), linepos)
						i = i + slen - 1
					Else
						dest = dest & converttab(Mid(source, i, Len(source) - i), linepos)
						i = Len(source)
					End If
					dest = dest & span_end
				ElseIf isEqual("QUOTATION2", source, i) Then
					dest = dest & quotation_span
					slen = InStr(i + 1, source, setting("QUOTATION2")) - i + Len(setting("QUOTATION2"))
					If slen > 0 Then
						dest = dest & converttab(Mid(source, i, slen), linepos)
						i = i + slen - 1
					Else
						dest = dest & converttab(Mid(source, i, Len(source) - i), linepos)
						i = Len(source)
					End If
					dest = dest & span_end
				Else
					'没有特殊意义，直接输出
					dest = dest & txt2htm(ch)
					linepos = linepos + 1
				End If
				'如果是换行符，就将行计数清零
				If (ch = vbLf) Then
					linepos = 0
				End If
			Else
				'不是分隔符，则将字符加入缓冲区
				buffer = buffer & ch
			End If
		Next
		private_analyze = dest & buffer
	End Function

	Private Function isEqual(name, source, offset)
		isEqual = isOptionEnable(name)
		isEqual = isEqual And InStr(offset, source, setting(name)) = offset
	End Function
End Class

下载地址

[ Last edited by sonicandy on 2007-10-28 at 08:51 AM ]

第1楼　sonicandy	发表于 2007-10-28 08:48
中级用户　发帖 91　积分 273
[讨论]vbs网页编辑器效率有点低,请高手帮忙看一下. 两个主要的问题: 1 是否可以将选择内容扩展到段落?也许这样可以提高效率. 2 编辑键捕获及过滤: 编辑操作有问题,选中一段后,按退格键应该是全部删除的,可是现在却只删除了一个字符. div.hta <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> <HTML> <hta:application> <HEAD> <TITLE> Editor </TITLE> <META NAME="Generator" CONTENT="EditPlus"> <META NAME="Author" CONTENT="sonic_andy"> <META NAME="Keywords" CONTENT="editor"> <META NAME="Description" CONTENT="a vbscript editor"> <style> p {padding:0 0 0 0; margin:0 0 0 0;} .editor {border:double; width:100%; height:60%; overflow:scroll;} .SCRIPTS {color:red} .QUOTATION {color:#800080} .COMMENT {color:green} .KEYWORD1 {color:blue} .KEYWORD2 {color:red} .KEYWORD3 {color:blue} .KEYWORD4 {color:blue} .KEYWORD5 {color:blue} .PREFIX_KEYWORD {color:brown} .SUFFIX_KEYWORD {color:brown} .DIGIT {color:brown} </style> <script language="vbscript" src="syntax.vbs"></script> <script language="vbscript"> Set oSC = New SyntaxColor Set reg = new regexp reg.ignorecase = True reg.global = True Set fso = CreateObject("scripting.filesystemobject") Sub writedebugfile(str2write) Set file = fso.opentextfile("debug.txt",2,true) Call file.write(str2write) Call file.close() Set file = Nothing End Sub Sub edit() If Not isValidKey() Then Exit Sub ' 得到并保存当前选中的位置 Set range = Document.selection.createrange() x = range.offsetleft y = range.offsettop l = Len(range.text) ' 过滤操作 str = Document.all.editor.innerhtml reg.pattern="<br>" str = reg.Replace(str,"<br>" & vbcrlf) reg.pattern="</?span>" str = reg.Replace(str,"") ' Document.all.status.value = str ' MsgBox "wait" ' oSC.infpath = "D:\CHDOC\vbstxclass" ' osc.stxpath = "D:\CHDOC\vbstxclass\stx" Call osc.get_syntax("vbs") str = osc.analyze_syntax(str) ' reg.pattern = vbcr ' str = reg.Replace(str,"<br>" & vbcrlf) Document.all.editor.innerhtml = str ' 恢复当前位置 Call range.movetoelementtext(Document.all.editor) Call range.movetopoint(x,y) Call range.moveend("character",l) ' Call range.collapse(false) ' Call range.expand("word") Call range.Select() Document.all.status.value = Document.all.editor.innerhtml End Sub Function isValidKey() Select Case Window.event.keycode Case 37,38,39,40 ' Left,Up,Right,Down isValidKey = False Exit Function Case 33,34,35,36 ' Home,End,PgUp,PgDn isValidKey = False Exit Function Case 16,17 ' Shift,Ctrl isValidKey = False Exit Function End Select If Window.event.altkey Then ' 按下Alt isValidKey = False Exit Function End If If Window.event.ctrlkey Then ' 按下Ctrl isValidKey = False Exit Function End If isValidKey = True End Function Sub filterkey() If Not isValidKey() Then Exit Sub Set range = Document.selection.createrange() ' 处理tab键 If Window.event.keycode=Asc(vbtab) Then Window.event.returnvalue = False range.text = vbtab End If Call range.collapse(false) Call range.Select() End Sub Sub syc() Document.all.status.value = Document.all.editor.innerhtml End Sub </script> </HEAD> <BODY> <div id="editor" contenteditable class="editor" onkeydown="filterkey" onkeyup="edit"></div> <br> <textarea id="status" cols="120" rows="10"></textarea> <br> <input type="button" value="同步" onclick="syc"> </BODY> </hta:application> </HTML> syntax.vbs Option Explicit ' 语法着色类 sonic_andy 'Set test = New SyntaxColor 'Call test.get_syntax("vbs") 'msgbox test.analyze_syntax("asdfasdf") class SyntaxColor Private quotation_span '引用标记 Private comment_span '注释标记 Private script_span '脚本标记 Private keyword_span '关键字标记 Private prefix_keyword_span '前缀关键字标记 Private suffix_keyword_span '后缀关键字标记 Private digit_span '数字标记 Private span_end '结束标记 Private setting '当前 Private keyword() '关键字字符串 Private prefix '前缀 Private suffix '后缀 Private html_instance 'a html instance Private mtabwidth 'tab宽度 Public infpath 'inf文件路径 Public stxpath 'stx文件路径 Private fso '文件系统对象 Private reg '正则表达式对象 Private Sub Class_Initialize() quotation_span = "<SPAN CLASS=QUOTATION>" comment_span = "<SPAN CLASS=COMMENT>" script_span = "<SPAN CLASS=SCRIPTS>" prefix_keyword_span = "<SPAN CLASS=PREFIX_KEYWORD>" suffix_keyword_span = "<SPAN CLASS=SUFFIX_KEYWORD>" digit_span = "<SPAN CLASS=DIGIT>" keyword_span = Array( _ "<SPAN CLASS=KEYWORD1>", _ "<SPAN CLASS=KEYWORD2>", _ "<SPAN CLASS=KEYWORD3>", _ "<SPAN CLASS=KEYWORD4>", _ "<SPAN CLASS=KEYWORD5>") span_end = "</SPAN>" Set setting = CreateObject("scripting.dictionary") setting.CompareMode = vbTextCompare ReDim keyword(0) Set fso = CreateObject("scripting.filesystemobject") Set reg = New RegExp reg.IgnoreCase = True reg.Global = True infpath = ".\" stxpath = ".\stx\" mtabwidth = 4 End Sub ' 从"ext.inf"文件中读取扩展名和分析信息文件的对应关系, ' 并且调用get_info函数得到语法相关信息数组. ' ' @param string ext 需要分析内容的扩展名 Public Function get_syntax(ext) Dim file ' 文件流对象 Dim configure ' 文件内容 Dim lines ' 被换行分隔的内容数组 Dim arr ' 每一行中,被等号分隔的内容 Dim i '得到扩展名和相关文件名配置文件的内容 Set file = fso.OpenTextFile(fso.BuildPath(infpath, "ext.inf"), 1) 'vbide configure = file.ReadAll Call file.Close '将内容分割到数组 lines = Split(configure, vbCrLf) For i = LBound(lines) To UBound(lines) '先用等号分割将字符串转换为数组array arr = Split(lines(i), "=") '查找"扩展名;"是否在字符串array中 If InStr(arr(1), ext & ";") > 0 Then Call get_info(arr(0)) get_syntax = True End If Next get_syntax = False End Function ' 从语法文件中读取语法信息,并且将它存贮到信息数组中 ' ' @param string filename 语法信息文件名 Private Function get_info(filename) Dim file ' 文件流对象 Dim sfile ' 文件内容 Dim arr ' 被\n#分隔的内容 Dim i '读取语法文件内容 Set file = fso.OpenTextFile(fso.BuildPath(stxpath, filename), 1) ' vbide sfile = file.ReadAll Call file.Close '清除行首的注释 reg.Pattern = "(\n;\n)" sfile = reg.Replace(sfile, vbCrLf) '清除多余的空行 reg.Pattern = "(+)" sfile = reg.Replace(sfile, vbCrLf) '用井号将内容分割为数组 arr = Split(sfile, vbCrLf & "#") For i = LBound(arr) To UBound(arr) If arr(i) <> "" Then Dim pos ' 等号的位置 Dim name ' 等号前的名称 Dim value ' 等号后的值 pos = InStr(arr(i), "=") name = Mid(arr(i), 1, pos - 1) name = Replace(name, "#", "") value = Mid(arr(i), pos + 1) If InStr(name, "KEYWORD") = 1 Then '名称是关键字（keyword） Dim temp ' 临时字符串 temp = Mid(value, InStr(value, vbCrLf)) & vbCrLf keyword(UBound(keyword)) = temp ReDim Preserve keyword(UBound(keyword) + 1) Else value = Replace(value, vbCr, "") value = Replace(value, vbLf, "") If name = "PREFIX" Then prefix = prefix & value ElseIf name = "SUFFIX" Then suffix = suffix & value ElseIf name = "DELIMITER" Then setting(name) = value & vbCrLf & vbTab & " " ElseIf name <> "" And value <> "" Then '若名称不为空,去掉回车加入数组 setting(name) = Replace(value, vbCrLf, "") End If End If End If Next '创建并设置本类的html实例 If ((isOptionEnable("HTML_EMBEDDED")) And setting("HTML_EMBEDDED") = "y") Then Set html_instance = New SyntaxColor html_instance.get_syntax ("html") html_instance.set_tabwidth (mtabwidth) End If End Function ' 将字符串中的tab键转换为空格，并且将结果字符串作为html编码返回 ' 该函数作为引用、注释等特殊情况的处理函数被analyze_syntax函数调用。 ' ' @param string str 源字符串 ' @param int linepos 当前行的位置 ' @param int mtabwidth tab键的宽度 ' @return 结果字符串 Private Function converttab(str, linepos) Dim dest ' 目标字符串 Dim i Dim ch ' 第i个字符 Dim offset ' 小于于设定tab宽度的行偏移量 dest = "" For i = 1 To Len(str) ch = Mid(str, i, 1) If (ch = "\t") Then offset = mtabwidth - linepos Mod mtabwidth dest = dest & Space(offset) linepos = linepos + offset Else dest = dest & ch linepos = linepos + 1 End If If (ch = "\n") Then linepos = 0 End If Next converttab = txt2htm(dest) End Function Private Function txt2htm(str) txt2htm = str txt2htm = Replace(txt2htm, "", "") End Function ' 设置tab宽度 ' ' @param int mtabwidth Public Property Let tabwidth(ntab) mtabwidth = ntab If ((isOptionEnable("HTML_EMBEDDED")) And setting("HTML_EMBEDDED") = "y") Then html_instance.set_tabwidth (mtabwidth) End If End Property Public Property Get tabwidth() tabwidth = mtabwidth End Property ' 外部使用，语法着色功能函数 ' ' @param string source Public Function analyze_syntax(source) Dim dest ' 目标字符串 Dim i dest = "" If ((isOptionEnable("HTML_EMBEDDED")) And setting("HTML_EMBEDDED") = "y") Then i = 0 While (True) Dim slen ' 作用域长度 slen = InStr(i, source, setting("SCRIPT_BEGIN")) - i If (slen >= 0) Then dest = dest & html_instance.private_analyze(Mid(source, i, slen)) i = i + slen slen = InStr(i, source, setting("SCRIPT_END")) - i + Len(setting("SCRIPT_END")) If (slen > 0) Then dest = dest & private_analyze(Mid(source, i, slen)) i = i + slen End If Else dest = dest & html_instance.private_analyze(Mid(source, i)) analyze_syntax = dest Exit Function End If Wend Else analyze_syntax = private_analyze(source) End If End Function Private Function isOptionEnable(name) If setting.Exists(name) Then If setting(name) <> "" Then isOptionEnable = True Exit Function End If End If isOptionEnable = False End Function ' 分析词法,并着色(内部使用). ' ' @param string source 源字符串 ' @param int mtabwidth tab的宽度 ' @return string 着色后的字符串 Private Function private_analyze(source) Dim dest: dest = "" ' 目标字符串 Dim ch: ch = "" ' 当前字符 Dim buffer: buffer = "" ' 缓冲区 Dim linepos: linepos = 0 '行计数 Dim offset Dim slen Dim i Dim CompareMode If isOptionEnable("CASE") And setting("CASE") = "y" Then reg.IgnoreCase = False Else reg.IgnoreCase = True End If '去掉源字符串的反斜杠 'source = stripslashes(source) For i = 1 To Len(source) ch = Mid(source, i, 1) If (InStr(setting("DELIMITER"), ch) > 0) Then '将缓冲区中字符串的长度计算加入行位置变量 linepos = linepos + Len(buffer) '缓冲区不为空的话就分析缓冲区内容是否是关键字 If (buffer <> "") Then Dim j For j = 0 To UBound(keyword) reg.Pattern = "\b" & buffer & "\b" If (reg.Test(keyword(j))) Then dest = dest & keyword_span(j) & txt2htm(buffer) & span_end buffer = "" Exit For End If Next End If '缓冲区不为空的话就分析缓冲区内容是否是前缀关键字/后缀关键字,并检查是否是数字 If buffer <> "" Then If (Not IsEmpty(prefix) And InStr(prefix, Mid(buffer, 1, 1)) > 0) Then dest = dest & prefix_keyword_span & txt2htm(buffer) & span_end buffer = "" ElseIf (Not IsEmpty(suffix) And InStr(suffix, Mid(buffer, Len(buffer), 1)) > 0) Then dest = dest & suffix_keyword_span & txt2htm(buffer) & span_end buffer = "" ElseIf ((isOptionEnable("NUMBER_PATTERN")) And _ setting("NUMBER_PATTERN") = "cpp" And IsNumeric(buffer)) Then dest = dest & digit_span & txt2htm(buffer) & span_end buffer = "" End If End If '如果缓冲区还不为空，就输出缓冲区 If buffer <> "" Then dest = dest & txt2htm(buffer) buffer = "" End If '开始判断分隔符是否是有意义的字符 If ch = vbLf Then offset = mtabwidth - linepos Mod mtabwidth dest = dest & txt2htm(Space(offset)) linepos = linepos + offset ElseIf isEqual("LINECOMMENT", source, i) Then dest = dest & comment_span slen = InStr(i, source, vbCrLf) - i If slen > 0 Then dest = dest & converttab(Mid(source, i, slen), linepos) i = i + slen - 1 Else dest = dest & converttab(Mid(source, i, Len(source) - i), linepos) i = Len(source) End If dest = dest & span_end ElseIf isEqual("LINECOMMENT2", source, i) Then dest = dest & comment_span slen = InStr(i, source, vbCrLf) - i If (slen > 0) Then dest = dest & converttab(Mid(source, i, slen), linepos) i = i + slen - 1 Else dest = dest & converttab(Mid(source, i, Len(source) - i), linepos) i = Len(source) End If dest = dest & span_end ElseIf isEqual("COMMENTON", source, i) Then dest = dest & comment_span slen = InStr(i + 1, source, setting("COMMENTOFF")) - i + Len(setting("COMMENTOFF")) If slen > 0 Then dest = dest & converttab(Mid(source, i, slen), linepos) i = i + slen - 1 Else dest = dest & converttab(Mid(source, i, Len(source) - i), linepos) i = Len(source) End If dest = dest & span_end ElseIf isEqual("COMMENTON2", source, i) Then dest = dest & comment_span slen = InStr(i + 1, source, setting("COMMENTOFF2")) - i + Len(setting("COMMENTOFF2")) If slen > 0 Then dest = dest & converttab(Mid(source, i, slen), linepos) i = i + slen - 1 Else dest = dest & converttab(Mid(source, i, Len(source) - i), linepos) i = Len(source) End If dest = dest & span_end ElseIf isEqual("QUOTATION1", source, i) Then dest = dest & quotation_span slen = InStr(i + 1, source, setting("QUOTATION1")) - i + Len(setting("QUOTATION1")) If slen > 0 Then dest = dest & converttab(Mid(source, i, slen), linepos) i = i + slen - 1 Else dest = dest & converttab(Mid(source, i, Len(source) - i), linepos) i = Len(source) End If dest = dest & span_end ElseIf isEqual("QUOTATION2", source, i) Then dest = dest & quotation_span slen = InStr(i + 1, source, setting("QUOTATION2")) - i + Len(setting("QUOTATION2")) If slen > 0 Then dest = dest & converttab(Mid(source, i, slen), linepos) i = i + slen - 1 Else dest = dest & converttab(Mid(source, i, Len(source) - i), linepos) i = Len(source) End If dest = dest & span_end Else '没有特殊意义，直接输出 dest = dest & txt2htm(ch) linepos = linepos + 1 End If '如果是换行符，就将行计数清零 If (ch = vbLf) Then linepos = 0 End If Else '不是分隔符，则将字符加入缓冲区 buffer = buffer & ch End If Next private_analyze = dest & buffer End Function Private Function isEqual(name, source, offset) isEqual = isOptionEnable(name) isEqual = isEqual And InStr(offset, source, setting(name)) = offset End Function End Class 下载地址 [ Last edited by sonicandy on 2007-10-28 at 08:51 AM* ]

第2楼　sonicandy	发表于 2007-11-26 21:07
中级用户　发帖 91　积分 273
改成ActiveX了,效果还可以,机制改为F5刷新.如果有兴趣可以去http://myvbscript.googlecode.com