PublicSub HighLight()Sub HighLight(RTB As RichTextBox, lColor AsLong) 'add new color to color table 'add tags \highlight# and \highlight0 'where # is new color number Dim iPos AsLong Dim strRTF AsString Dim bkColor AsInteger With RTB iPos = .SelStart 'bracket selection .SelText =Chr(&H9D) & .SelText &Chr(&H81) strRTF = RTB.TextRTF 'add new color bkColor = AddColorToTable(strRTF, lColor) 'add highlighting strRTF =Replace(strRTF, "\'9d", "\up1\highlight"&CStr(bkColor) &"") strRTF =Replace(strRTF, "\'81", "\highlight0\up0 ") .TextRTF = strRTF .SelStart = iPos EndWith End Sub
Function AddColorToTable()Function AddColorToTable(strRTF AsString, lColor AsLong) AsInteger Dim iPos AsLong, jpos AsLong Dim ctbl AsString Dim tagColors Dim nColors AsInteger Dim tagNew AsString Dim i AsInteger Dim iLen AsInteger Dim split1 AsString Dim split2 AsString 'make new color into tag tagNew ="\red"&CStr(lColor And&HFF) & _ "\green"&CStr(Int(lColor /&H100) And&HFF) & _ "\blue"&CStr(Int(lColor /&H10000)) 'find colortable iPos =InStr(strRTF, "{\colortbl") If iPos >0Then'if table already exists jpos =InStr(iPos, strRTF, ";}") 'color table ctbl =Mid(strRTF, iPos +12, jpos - iPos -12) 'array of color tags tagColors =Split(ctbl, ";") nColors =UBound(tagColors) +2 'see if our color already exists in table For i =0ToUBound(tagColors) If tagColors(i) = tagNew Then AddColorToTable = i +1 Exit Function EndIf Next i '{\fonttbl{\f0\fnil\fcharset0 Verdana;}} '{\colortbl ;\red0\green0\blue0;\red128\green0\blue255;} split1 =Left(strRTF, jpos) split2 =Mid(strRTF, jpos +1) strRTF = split1 & tagNew &";"& split2 AddColorToTable = nColors Else 'color table doesn't exists, let's make one iPos =InStr(strRTF, "{\fonttbl") 'beginning of font table jpos =InStr(iPos, strRTF, ";}}") +2'end of font table split1 =Left(strRTF, jpos) split2 =Mid(strRTF, jpos +1) strRTF = split1 &"{\colortbl ;"& tagNew &";}"& split2 AddColorToTable =1 EndIf End Function
posted on
2006-09-06 17:08陈锐
阅读(1154)
评论(2)
编辑收藏举报