accidenceblock.pas

一个可以把源代码以语法高亮的形式转换成HTML格式或RTF格式。

                       // 即：空格、Tab键、未定义符号或其他多字节字符等
          SI := Col;
          while (Col <=Len) and
                (Not (LS[Col] in ['a'..'z','A'..'Z','0'..'9','_']) ) and
                ((Not (LS[Col] in FSymbolFirstSet)) or
                 ((LS[Col] in FSymbolFirstSet) and Not LocalIsSymbol)) do
          begin  // 不属于数字、标识符、已定义符号  即 常规字符
            {if ByteType(LS,Col)= mbLeadByte then             // 双字节前缀 - 汉字
            begin
              Inc(Col);
              if ByteType(LS,Col)= mbTrailByte then Inc(Col);// 后缀
            end
            else }
            
            Inc(Col);
          end;
          // 属性中
          if AttrNoHight and (Col>1) and (LS[Col] in FirstIdentChar) and (LS[Col-1]='.') then
          begin
            while (Col<=Len) and (LS[Col] in
              ['A'..'Z', 'a'..'z', '_', '0'..'9','.']) do Inc(Col);
          end;

          PrveToken := PrveToken + Copy(LS,SI,Col-SI);

        end;   // if LS[Col] Lastelse ... end.


      if (Col>Len) and FIsEach then AddPrveToken ;  // 要每行必写结束符要用
      // 每行只要有内容，保证执行一次 ..Html -> 改到写有字体符号前写就够了 --未实现

    end;     // while Col <= Len do end.
    AddPrveToken ;                                   // 每行最后保证执行一次 
    if Row < FSrc.Count then FConvBuilder.EndLine;   // 多行符号时不要重复写尾
    Inc(Row);

    //每循环10次通知外面一次
    if Row mod 10 = 0 then
      DoConvProgress(self,10);
  end;
end;


procedure TAccidence.DoAfterConvert(Sender:TObject; Count: Integer);
begin
  if Assigned(FOnAfterConvert) then
    FOnAfterConvert(self,Count);
end;

procedure TAccidence.DoBeforeConvert(Sender:TObject; Count: Integer);
begin
  if Assigned(FOnBeforeConvert) then
    FOnBeforeConvert(self,Count);
end;

procedure TAccidence.DoConvProgress(Sender:TObject; Progress: Integer);
begin
  if Assigned(FOnConvProgress) then
    FOnConvProgress(self,Progress);
end;

{ TConvHTML }

constructor TConvHTML.Create;
begin
  inherited;
  FSpace := False;  // 不用 <pre> 时最好设置为 True,否则空格会当作无
                    // 缺点：不使用 &nbsp; 替换所有空格，
                    //       复制到 word 之类(剪贴板HTML格式)时
                    //       字符之间会产生不对齐，WebBrowser 查看基本没问题
                    //        但有可能受字体影响。
  FUsesPreToken := True;
  FStyles := TStringList.Create;
  FCharSet := GetCharSet;  // 配置文件中的字符集设置，默认为 gb2312
end;

destructor TConvHTML.Destroy;
begin
  FStyles.Free;
  inherited;
end;


function TConvHTML.ChangeSpeChar(C: Char): string;
begin
  Result := C;
  ChangeSpeString(Result);
end;

procedure TConvHTML.ChangeSpeString(var S: string);
begin
  S := StringReplace(S, '&', '&amp;', [rfReplaceAll]);
  S := StringReplace(S, '<', '&lt;', [rfReplaceAll]);
  S := StringReplace(S, '>', '&gt;', [rfReplaceAll]);

  //注意: <Pre> 标记 ：空格不要在第一列,会出现不对齐 -- 原因不明
  //第一列为空格时转 ' ' -> &nbsp;      [#9 不转了,使用 pre 时]
{  if FLStr='' then // 第一个字串时
  begin
    S := StringReplace(S, ' ', '&nbsp;', [rfReplaceAll]);
  end; }
  if Not FSpace then
  begin
    {if (S<>'') and (S[1]=#9) and
       ((FUsesPreToken and (FLStr='')) or
        (Not FUsesPreToken and (FLStr='<br>'))) then
      S := '&nbsp;   ' + Copy(S,2,Length(S)-1);
    S := StringReplace(S, #9, '    ', [rfReplaceAll]); }
    if Not FAcciConfig.GeneralConfig.ShowLine and
       (S<> '') and (S[1] = ' ') and
       ((FUsesPreToken and (FLStr='')) or
        (Not FUsesPreToken and (FLStr='<br>'))) then
      S := //StringReplace(S, ' ', '&nbsp;', []);         
           '&nbsp;' + Copy(S,2,MaxInt);       // 比 StringReplace 还少一次 Copy
  end
  else
  begin
    S := StringReplace(S, #9, '    ', [rfReplaceAll]);
    S := StringReplace(S, ' ', '&nbsp;', [rfReplaceAll]);
  end;

  if FCharSet ='UTF-8' then
    S := UTF8Encode(S); // 只有UTF-8要转换格式  
end;

procedure TConvHTML.AddChar(C: Char; FontConfig: TFontConfig);
var
  LStr : string;
begin
  if C=#0 then Exit;
  LStr := ChangeSpeChar(C);
  if FontConfig <> nil then   //ToDo: 对象必已存在
    FLStr := Format('%s<%s class="%s">%s</%s>',
      [FLStr,'span',FStyles[FStyles.IndexOfObject(FontConfig)],
       LStr,'span'])
  else
    FLStr := FLStr + LStr;
end;

procedure TConvHTML.AddString(S: string; FontConfig: TFontConfig);
//var
//  IsSpace:Boolean;
begin
  //得先将一些特殊的字符转化成符合HTML的字符
  if S='' then Exit;
//  IsSpace := Trim(S) ='';
  ChangeSpeString(S);
{  if IsSpace then
  begin
    if (FTmp <> '') or ((FLStr<>'') and (Length(S)>12)) then
      //FLStr := FLStr + '<span class="G1">' + FTmp + S + '</span>'
      FTmp := FTmp + S
    else
    begin
      FLStr := FLStr + S;
    end;
    Exit;
  end;
}
  if FontConfig <> nil then
  begin
    if FTmp <>'' then
    begin
      if FTmp <> ' ' then
        FLStr := FLStr + '<span class="g1">' + FTmp + '</span>'
      else
        FLStr := FLStr + '&nbsp;';
      FTmp := '';
    end;                                             //ToDo: 对象必已存在
    //if (Not FUsesPreToken) or (Pos(#13,S)=0) then
      FLStr := Format('%s<%s class="%s">%s</%s>',
        [FLStr,'span',FStyles[FStyles.IndexOfObject(FontConfig)],
         S,'span']);
   { else
      FLStr := Format('%s<%s class="%s">%s</%s>',    // 使用 div 时会不对齐
        [FLStr,'div',FStyles[FStyles.IndexOfObject(FontConfig)],
         S,'div']) }
  end
  else
  begin
    //FLStr := FLStr + '<span class="G1">' + S + '</span>' ;
    FTmp := FTmp + S;
  end;
    //FLStr := FLStr + S ;
end;


function TConvHTML.CreateStyle(AFontConfig: TFontConfig;IsDocInner:Boolean): string;
begin
  //Result := '';
  with AFontConfig do
  begin
    // pt - 绝对单位 (点Points (1点 = 1/72英寸)) ,px - 相对单位 (像素Pixels)
    // CSS 的绝对单位是相对转出设备而言
{    if AFontConfig <> FAcciConfig.GeneralConfig.FontConfig then
    begin
      if AFontConfig.FontName <> FAcciConfig.GeneralConfig.FontConfig.FontName then
        Result := Result + 'font-family:"' + FontName + '"; ';
      if AFontConfig.FontSize <> FAcciConfig.GeneralConfig.FontConfig.FontSize then
        Result := Result + 'font-size:' + IntToStr(FontSize) + 'pt; ';
      if AFontConfig.FontColor <> FAcciConfig.GeneralConfig.FontConfig.FontColor then
        Result := Result + 'color:' + TColorToHTMLColor(FontColor) +'; ';
    end
    else
    begin }
      Result := 'font-family:"' + FontName + '"; ';
      Result := Result + 'font-size:' + IntToStr(FontSize) + 'pt; ';
      Result := Result + 'color:' + TColorToHTMLColor(FontColor) +'; ';

      {if AFontConfig = FAcciConfig.GeneralConfig.FontConfig then
        Result := Result + 'background-color: '+
          TColorToHTMLColor(FAcciConfig.GeneralConfig.BGround) + '; '; }
//    end;

    if fsBold in FontStyle then
      Result := Result + 'font-weight:Bold; ';
    if fsItalic in FontStyle then
      Result := Result + 'font-style:italic; ';

    if (fsUnderline in FontStyle) and
      not (fsStrikeOut in FontStyle) then
      Result := Result + 'text-decoration:underline; '
    else if not (fsUnderline in FontStyle) and
      (fsStrikeOut in FontStyle) then
      Result := Result + 'text-decoration:line-through; '
    else if (fsUnderline in FontStyle) and
      (fsStrikeOut in FontStyle) then
      Result := Result + 'text-decoration:line-through underline; ';

    if IsDocInner then  //Todo: 未使用 是否插入文档内部
      Result := ' Style="'+ Result +'" ';
  end;
end;

function TConvHTML.GetHead:string;
//var
//  i, j: Integer;
  //LStr1, LStr2: string;
begin
  //初始化头，及设定CSS风格
  //Result := '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">';
  Result := {Result + sLineBreak +} '<html>';
  Result := Result + sLineBreak + '<head>';
  //<!-- my liqj -->
  Result := Result + sLineBreak +
    '<meta http-equiv="content-type" content="text/html;charset='+
      FCharSet +'">';  //gb2312
//  Result := Result + sLineBreak +
//    '<meta content="original=http://blog.csdn.net/linzhengqun">';
// Result := Result + sLineBreak + '<meta modify="liqj">';
//  if FAcciConfig.GeneralConfig.ShowLine then
//    Result := Result + sLineBreak +
//      Format('<meta linecount="%d" linedigit="%d">',[FLineCount,FLineDigit]);
  Result := Result + sLineBreak + '<meta name="author" content="[e-mail]">';
  //Result := Result + sLineBreak + '<meta name="description" content="简介"> ';
  Result := Result + sLineBreak + '<meta name="keywords" content="'+ FAcciConfig.AccidenceName +'">';
  Result := Result + sLineBreak + '<title>' + FTitle + '</title>';
  Result := Result + sLineBreak + '<!-- Highlight Accidence:' + FAcciConfig.AccidenceName +' -->';
  Result := Result + sLineBreak + FStyle ;

{  Result := Result + sLineBreak + '<style type="text/css">';
  Result := Result + sLineBreak + '<!--';

  for i := 0 to FStyles.Count - 1 do
  begin
    j := Pos(' ',FStyles[i]);   // 空格前为 Class 定义 后部份为名称
    LStr1 := Copy(FStyles[i],1,j-1);
    LStr2 := Copy(FStyles[i],j+1,MaxInt);

   if (LStr1<>'') and (LStr1[1]='S') then // 符号
    begin
      for j :=0 to FAcciConfig.Symbols.Count -1 do
      begin
        if TSymbolConfig(FAcciConfig.Symbols.Items[j]).FontConfig =
           FStyles.Objects[i] then
        with TSymbolConfig(FAcciConfig.Symbols.Items[j]) do
        begin
          LStr2 := LStr2 + ' 范围:'+ Range  ;
          LStr2 := LStr2 + ' 值:'+ BeginValue +' - '+ IfThen(EndValue<>'',EndValue,'无') ;
          LStr2 := LStr2 + ' 转义符:' + IfThen(ESC='','无',ESC);
        end;
     end;
    end; }
    //加进一种字体风格           // .class 换行 /* 名称 */ 换行  { 样式内容 }
//    if i=0 then
//     Result := Result + sLineBreak + Format('body %s    { /* %s */%s      %s }',
//        [ sLineBreak, LStr2 ,sLineBreak, CreateStyle(TFontConfig(FStyles.Objects[i]))])
//    else
//     Result := Result + sLineBreak + Format('.%s%s    { /* %s */%s      %s }',
//        [LStr1, sLineBreak, LStr2 ,sLineBreak, CreateStyle(TFontConfig(FStyles.Objects[i]))]);
//
//  end;
//  Result := Result + sLineBreak + '-->';
//  Result := Result + sLineBreak + '</style>';
  Result := Result + sLineBreak + '</head>';              // class="g1">';//
  Result := Result + sLineBreak + '<body>';// style="background-color:' +
//        TColorToHTMLColor(FAcciConfig.GeneralConfig.BGround)+ '">';

//  Result := Result + sLineBreak + '<div class="G0"><br>';
//    FStyles[FStyles.IndexOfObject(FAcciConfig.GeneralConfig.FontConfig)]+'"><br>';
  if FUsesPreToken then Result := Result + sLineBreak + '<pre>' ;
end;

function TConvHTML.GetEnd:string;
begin                          // +'<br>'</div>
  if FUsesPreToken then
    Result := '</pre>'+ sLineBreak + '</body>'+ sLineBreak +'</html>'
  else
    Result := '</body>'+ sLineBreak +'</html>';
end;


procedure TConvHTML.EndLine;
begin
  if FTmp <>'' then
  begin
    if Trim(FTmp) <> '' then  // 后缀空格不处理
    begin
      FLStr := FLStr + '<span class="g1">'+ FTmp + '</span>';
    end;
    FTmp := '';
  end;
  inherited;
end;

procedure TConvHTML.Init(Lines: Integer; AcciConfig: TAccidenceConfig);
var
  j: Integer;
  sTmp : string;
  KWConfig: TKeyWordConfig;
  SMConfig: TSymbolConfig;
begin
  inherited;
  //组建风格与字体对象的哈希表  , 名称为配置类型的简写
  
  FStyle := '<style type="text/css">';
  FStyle := FStyle + sLineBreak + '<!--';
  FStyle := FStyle + sLineBreak + 'body { background-color: '+
    TColorToHTMLColor(FAcciConfig.GeneralConfig.BGround) +' }';
  FStyle := FStyle + sLineBreak + '/*  General  */';
  FStyle := FStyle + sLineBreak + Format('.g1  { %s}',
        [ CreateStyle(AcciConfig.GeneralConfig.FontConfig)]) ;
  FStyle := FStyle + sLineBreak + '/*  Number  */';
  FStyle := FStyle + sLineBreak + Format('.n1  { %s}',
        [ CreateStyle(AcciConfig.NumberConfig.FontConfig)]) ;

  FStyles.AddObject('g1',AcciConfig.GeneralConfig.FontConfig);
  FStyles.AddObject('n1', AcciConfig.NumberConfig.FontConfig);
  FStyle := FStyle + sLineBreak + '/*  KeyWords  */';
  for j := 0 to AcciConfig.KeyWords.Count - 1 do
  begin
    KWConfig := TKeyWordConfig(AcciConfig.KeyWords.Items[j]);
    FStyles.AddObject('k' + IntToStr(j+1), KWConfig.FontConfig);

    FStyle := FStyle + sLineBreak + Format('.k%d  {%s     /* %s ,count(%d) */%s      %s}',
        [ j+1,sLineBreak, KWConfig.Name ,KWConfig.Values.Count, sLineBreak,
          CreateStyle(KWConfig.FontConfig)]) ;
  end;
  FStyle := FStyle + sLineBreak + '/*  Symbols  */';
  for j := 0 to AcciConfig