Code:
<!--
+---------------------------------------------------------------------------+
VB-WORLD Forums - Tagging Scripts 1.0
Programmed By A.Conybeare
[email protected]
+---------------------------------------------------------------------------+
-->
<SCRIPT LANGUAGE = "VBScript">
Const KeyColor = "#0000A0" ' Keyword colour (Blue)
Const REMColor = "#00A000" ' Comment colour (Green)
Const STRColor = "#ff0000" ' String Colour (Red)
Const NUMColor = "#a52a2a" ' Numeric Colour (Brown)
Dim oWindow,oDocument,oSelect,oSelectRange,key,grep,KeyWords
Set oWindow = window.external.menuArguments
Set oSource = oWindow.event.srcElement
Set oDocument = oWindow.document
Set oSelect = oDocument.selection
Set oSelectRange = oSelect.createRange()
'KeyWords Add your own keywords if You Want !
KeyWords="&,:,-,=,>,<,>=,<=,<>,!,/,^,@,ACCESS,ACCOUNT,ACTIVATE,ADD,ADMIN,ADVISE,AFTER,ALL,ALL_ROWS,ALLOCATE,ALTER,ANALYZE,AND,ANY,ARCHIVE,ARCHIVELOG,ARRAY,AS,ASC,AT,AUDIT,AUTHENTICATED,AUTHORIZATION,AUTOEXTEND,AUTOMATIC,BACKUP,BECOME,BEFORE,BEGIN,BETWEEN,BFILE,BITMAP,BLOB,BLOCK,BODY,BY,CACHE,CACHE_INSTANCES,CANCEL,CASCADE,CAST,CFILE,CHAINED,CHANGE,CHAR,CHAR_CS,CHARACTER,CHECK,CHECKPOINT,CHOOSE,CHUNK,CLEAR,CLOB,CLONE,CLOSE,CLOSE_CACHED_OPEN_CURSORS,CLUSTER,COALESCE,COLUMN,COLUMNS,COMMENT,COMMIT,COMMITTED,COMPATIBILITY,COMPILE,COMPLETE,COMPOSITE_LIMIT,COMPRESS,COMPUTE,CONNECT,CONNECT_TIME,CONSTRAINT,CONSTRAINTS,CONTENTS,CONTINUE,CONTROLFILE,CONVERT,COST,CPU_PER_CALL,CPU_PER_SESSION,CREATE,CURRENT,CURRENT_SCHEMA,CURRENT_USER,CURSOR,CYCLE,DANGLING,DATABASE,DATAFILE,DATAFILES,DATAOBJNO,DATE,DBA,DBHIGH,DBLOW,DBMAC,DEALLOCATE,DEBUG,DEC,DECIMAL,DECLARE,DEFAULT,DEFERRABLE,DEFERRED,DEGREE,DELETE,DEREF,DESC,DIRECTORY,DISABLE,DISCONNECT,DISMOUNT,DISTINCT,DISTRIBUTED,DML,DOUBLE,DROP,DUMP,EACH,ELSE,ENABLE,END,ENFORCE,ENTRY,ESCAPE,ESTIMATE,EVENTS,EXCEPT,EXCEPTIONS,EXCHANGE,EXCLUDING,EXCLUSIVE,EXECUTE,EXISTS,EXPIRE,EXPLAIN,EXTENT,EXTENTS,EXTERNALLY,FAILED_LOGIN_ATTEMPTS,FALSE,FAST,FILE,FIRST_ROWS,FLAGGER,FLOAT,FLOB,FLUSH,FOR,FORCE,FOREIGN,FREELIST,FREELISTS,FROM,FULL,FUNCTION,GLOBAL,GLOBALLY,GLOBAL_NAME,GRANT,GROUP,GROUPS,HASH,HASHKEYS,HAVING,HEADER,HEAP,IDENTIFIED,IDGENERATORS,IDLE_TIME,IF,IMMEDIATE,IN,INCLUDING,INCREMENT,INDEX,INDEXED,INDEXES,INDICATOR,IND_PARTITION,INITIAL,INITIALLY,INITRANS,INSERT,INSTANCE,INSTANCES,INSTEAD,INT,INTEGER,INTERMEDIATE,INTERSECT,INTO,IS,ISOLATION,ISOLATION_LEVEL,KEEP,KEY,KILL,LABEL,LAYER,LESS,LEVEL,LIBRARY,LIKE,LIMIT,LINK,LIST,LOB,LOCAL,LOCK,LOCKED,LOG,LOGFILE,LOGGING,LOGICAL_READS_PER_CALL,LOGICAL_READS_PER_SESSION,LONG,MANAGE,MASTER,MAX,MAXARCHLOGS,MAXDATAFILES,MAXEXTENTS,MAXINSTANCES,MAXLOGFILES,MAXLOGHISTORY,MAXLOGMEMBERS,MAXSIZE,MAXTRANS,MAXVALUE,MIN,MEMBER,MINIMUM,MINEXTENTS,MINUS,MINVALUE,MLSLABEL,MLS_LABEL_FORMAT,MODE,MODIFY,MOUNT,MOVE,MTS_DISPATCHERS,MULTISET,NATIONAL,NCHAR,NCHAR_CS,NCLOB,NEEDED,NESTED,NETWORK,NEW,NEXT,NOARCHIVELOG,NOAUDIT,NOCACHE,NOCOMPRESS,NOCYCLE,NOFORCE,NOLOGGING,NOMAXVALUE,NOMINVALUE,NONE,NOORDER,NOOVERRIDE,NOPARALLEL,NORESETLOGS,NOREVERSE,NORMAL,NOSORT,NOT,NOTHING,NOWAIT,NULL,NUMBER,NUMERIC,NVARCHAR2,OBJECT,OBJNO,OBJNO_REUSE,OF,OFF,OFFLINE,OID,OIDINDEX,OLD,ON,ONLINE,ONLY,OPCODE,OPEN,OPTIMAL,OPTIMIZER_GOAL,OPTION,OR,ORDER,ORGANIZATION,OSLABEL,OVERFLOW,OWN,PACKAGE,PARALLEL,PARTITION,PASSWORD,PASSWORD_GRACE_TIME,PASSWORD_LIFE_TIME,PASSWORD_LOCK_TIME,PASSWORD_REUSE_MAX,PASSWORD_REUSE_TIME,PASSWORD_VERIFY_FUNCTION,PCTFREE,PCTINCREASE,PCTTHRESHOLD,PCTUSED,PCTVERSION,PERCENT,PERMANENT,PLAN,PLSQL_DEBUG,POST_TRANSACTION,PRECISION,PRESERVE,PRIMARY,PRIOR,PRIVATE,PRIVATE_SGA,PRIVILEGE,PRIVILEGES,PROCEDURE,PROFILE,PUBLIC,PURGE,QUEUE,QUOTA,RANGE,RAW,RBA,READ,READUP,REAL,REBUILD,RECOVER,RECOVERABLE,RECOVERY,REF,REFERENCES,REFERENCING,REFRESH,RENAME,REPLACE,RESET,RESETLOGS,RESIZE,RESOURCE,RESTRICTED,RETURN,RETURNING,REUSE,REVERSE,REVOKE,ROLE,ROLES,ROLLBACK,ROW,ROWID,ROWNUM,ROWS,RULE,SAMPLE,SAVEPOINT,SB4,SCAN_INSTANCES,SCHEMA,SCN,SCOPE,SD_ALL,SD_INHIBIT,SD_SHOW,SEGMENT,SEG_BLOCK,SEG_FILE,SELECT,SEQUENCE,SERIALIZABLE,SESSION,SESSION_CACHED_CURSORS,SESSIONS_PER_USER,SET,SHARE,SHARED,SHARED_POOL,SHRINK,SIZE,SKIP,SKIP_UNUSABLE_INDEXES,SMALLINT,SNAPSHOT,SOME,SORT,SPECIFICATION,SPLIT,SQL_TRACE,STANDBY,START,STATEMENT_ID,STATISTICS,STOP,STORAGE,STORE,STRUCTURE,SUCCESSFUL,SWITCH,SYS_OP_ENFORCE_NOT_NULL$,SYS_OP_NTCIMG$,SYNONYM,SYSDATE,SYSDBA,SYSOPER,SYSTEM,TABLE,TABLES,TABLESPACE,TABLESPACE_NO,TABNO,TEMPORARY,THAN,THE,THEN,THREAD,TIMESTAMP,TIME,TO,TOPLEVEL,TRACE,TRACING,TRANSACTION,TRANSITIONAL,TRIGGER,TRIGGERS,TRUE,TRUNCATE,TX,TYPE,UB2,UBA,UID,UNARCHIVED,UNDO,UNION,UNIQUE,UNLIMITED,UNLOCK,UNRECOVERABLE,UNTIL,UNUSABLE,UNUSED,UPDATABLE,UPDATE,USAGE,USE,USER,USING,VALIDATE,VALIDATION,VALUE,VALUES,VARCHAR,VARCHAR2,VARYING,VIEW,WHEN,WHENEVER,WHERE,WITH,WITHOUT,WORK,WRITE,WRITEDOWN,WRITEUP,XID"
key = Split(KeyWords, ",")
Set grep = New regexp
If oSource.tagName = "TEXTAREA" Then
oSelectRange.text = "
Code:
" & GetColoredCode(oSelectRange.text) & "
"
End If
Function GetColoredCode(Stxt)
Dim i,j,Data,RepData,lineArray,QtArray,Matches
Data = " " & Stxt & " "
grep.Global = True
grep.IgnoreCase = True
' Number Search
Data = ereg_replace(data, "(\=|>|<|\=\s|>\s|<\s|between\s|and\s)([0-9]+)", "$1[NUM]$2[/NUM]", True)
' Keyword search
For i = 0 To UBound(key)
' This works but finds matches with single quotes?
Data = ereg_replace(Data, "(^\s+|[\s(,])(" & key(i) & ")(\s|\)|\,|$)", "$1[KWD]$2[/KWD]$3", True)
Next
' String Search (text in single quotes)
Data = DoString(Data)
' Comment Search
Data = Mid(Data, 2, Len(Data) - 2)
lineArray = Split(Data, vbCrLf)
For i = 0 To UBound(lineArray)
QtArray = Split(lineArray(i), Chr(34))
For j = 0 To UBound(QtArray)
Apop = InStr(1, QtArray(j), "--")
If ((j Mod 2 = 0) Or (j = UBound(QtArray))) And Apop > 0 Then
QtArray = CommentFrom(QtArray, j, Apop)
Exit For
ElseIf (j Mod 2 <> 0) Then
QtArray(j) = StripTags(QtArray(j))
End If
Next
lineArray(i) = Join(QtArray, Chr(34))
Next
Data = Join(lineArray, vbCrLf)
Data = Replace(Data, "[KWD]", "[color=" & Chr(34) & KeyColor & Chr(34) & "]") ' Keywords
Data = Replace(Data, "[/KWD]", "[/color]")
Data = Replace(Data, "[NUM]", "[color=" & Chr(34) & NUMColor & Chr(34) & "]") ' Numerics
Data = Replace(Data, "[/NUM]", "[/color]")
Data = Replace(Data, "[STR]", "[color=" & Chr(34) & STRColor & Chr(34) & "]") ' Strings
Data = Replace(Data, "[/STR]", "[/color]")
Data = Replace(Data, "[REM]", "[color=" & Chr(34) & REMColor & Chr(34) & "]") ' Comments
Data = Replace(Data, "[/REM]", "[/color]")
GetColoredCode = Data
End Function
Function CommentFrom(srcArray,ByVal idx,ByVal pos)
Dim i,hd
If pos = 1 Then
hd = ""
Else
hd = Left(srcArray(idx), pos - 1)
End If
srcArray(idx) = hd & "[REM]" & StripTags(Mid(srcArray(idx), pos))
If idx < UBound(srcArray) Then
For i = idx + 1 To UBound(srcArray)
srcArray(i) = StripTags(srcArray(i))
Next
End If
srcArray(UBound(srcArray)) = srcArray(UBound(srcArray)) & "[/REM]"
CommentFrom = srcArray
End Function
Function StripTags(ByVal Strin)
Strin = replace(Strin, "[KWD]", "")
Strin = replace(Strin, "[/KWD]", "")
Strin = replace(Strin, "[NUM]", "")
Strin = replace(Strin, "[/NUM]", "")
Strin = replace(Strin, "[STR]", "")
Strin = replace(Strin, "[/STR]", "")
StripTags = Strin
End Function
Function ereg_replace(strOriginalString, strPattern, strReplacement, varIgnoreCase)
' Function replaces pattern with replacement
' varIgnoreCase must be TRUE (match is case insensitive) or FALSE (match is case sensitive)
Dim objRegExp: Set objRegExp = New RegExp
With objRegExp
.Pattern = strPattern
.IgnoreCase = varIgnoreCase
.Global = True
End With
ereg_replace = objRegExp.Replace(strOriginalString, strReplacement)
Set objRegExp = Nothing
End Function
Function DoString(strIn)
' Chr(39) = Single Quote (')
Dim sPos, fPos ' Start & Finish Positions
Dim blnDone
Dim repData
sPos = 1
fPos = 0
blnDone = False
Do While Not blnDone
sPos = InStr(sPos, strIn, Chr(39))
If sPos > 0 Then
' Found open quote
' Check whether tag is in already
If Not Mid(strIn, sPos - 5, 5) = "[STR]" Then
' Find closing quote
fPos = InStr(sPos + 1, strIn, Chr(39))
If fPos > 0 Then
'check for invalid tags
bLength = Len(Mid(strIn, sPos, (fPos + 1) - sPos))
repData = StripTags(Mid(strIn, sPos, (fPos + 1) - sPos))
aLength = Len(repData)
' Insert the tags
'repData = "[STR]" & StripTags(Mid(strIn, sPos, (fPos + 1) - sPos)) & "[/STR]"
repData = "[STR]" & repData & "[/STR]"
strIn = Replace(strIn, Mid(strIn, sPos, (fPos + 1) - sPos), repData)
sPos = (fPos - (blength - alength)) + 11 ' subtract any removed tags then Add the length of the current tags
Else: Exit Do ' Error: no closing quote found ignore rest
End If
Else
' Already done, find close and move to the next one
fPos = InStr(sPos + 1, strIn, Chr(39))
sPos = fPos + 6 ' Add the length of the closing tag
End If
Else
blnDone = True
Exit Do
End If
fPos = 0 ' Reset the finish pointer
Loop
' Return
DoString = strIn
End Function
</SCRIPT>
and it works like this:
