『楼 主』:
[讨论]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>
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[1]中
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]*\n)"
sfile = reg.Replace(sfile, vbCrLf)
'清除多余的空行
reg.Pattern = "([\n]+)"
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 ]
|
