📄 accidenceblock.pas

📁 一个可以把源代码以语法高亮的形式转换成HTML格式或RTF格式。
💻 PAS
📖 第 1 页 / 共 5 页
字号:
      Inc(BodyPosStart);                       
    Inc(BodyPosStart);                 

    // 写标准HTML头开始  <!DOCTYPE ...
    //if Pos('<!DOCTYPE',string(PChar(tmpoutStream.Memory)^)) then
    outStream.Write(DocHead,Length(DocHead));
    // 写源码头 <html>...<body>
    outStream.Write({tmpoutStream.Memory^}Utf8Str[1],BodyPosStart);
    StartPos :=outStream.Position;
    // 写内容开始标识
    outStream.Write(StartFragment,Length(StartFragment));
    // 写源码内容  <body> ... </body>
    outStream.Write((Pointer(Integer(@Utf8Str[1]{tmpoutStream.Memory}) + BodyPosStart))^,
       BodyPosEnd - BodyPosStart -1 );
    EndPos := outStream.Position ;   
    // 写内容结束标识    
    outStream.Write(EndFragment,Length(EndFragment));
    // 写源码结尾 </body></html>
    outStream.Write((Pointer(Integer(@Utf8Str[1]{tmpoutStream.Memory}) + BodyPosEnd -1)^),
        {tmpoutStream.Size} Length(Utf8Str) - BodyPosEnd-1); 

    // 写每个部份内容的位置信息
    //BodyPosStart{StartPos} := Pos(StartFragment,StrPas(outStream.Memory))+
    //              Length(StartFragment) -1 ;
    //BodyPosEnd{EndPos}   := Pos(EndFragment, StrPas(outStream.Memory)) - 1 ;
    HeadStr := Format(ClipHead,[HeadLen,outStream.Size,
                                StartPos,EndPos,StartPos,EndPos]);
    PCh := PAnsiChar(HeadStr);
    CopyMemory(outStream.Memory,PCh,HeadLen);
  finally
    //tmpoutStream.Free;
  end;
end;

// 未使用--
procedure WideStringToUTF8(Buf: WideString; Len: Integer; outStream: TStream);
const
  FirstByteMark: array[0..6] of Byte = ($00, $00, $C0, $E0, $F0, $F8, $FC);
  ReplacementCharacter: Cardinal = $0000FFFD;
  MaximumUCS2: Cardinal = $0000FFFF;
  MaximumUTF16: Cardinal = $0010FFFF;
  MaximumUCS4: Cardinal = $7FFFFFFF;
var
  Ch: Cardinal;
  L, J, T, BytesToWrite: Cardinal;
  ByteMask: Cardinal;
  ByteMark: Cardinal;
  R: AnsiString;
begin
  if Len = 0 then
    R := ''
  else
  begin
    SetLength(R, Len * 6);
    T := 1;
    ByteMask := $BF;
    ByteMark := $80;

    for J := 1 to Len do
    begin
      Ch := Cardinal(Buf[J]);

      if Ch < $80 then
        BytesToWrite := 1
      else
        if Ch < $800 then
          BytesToWrite := 2
        else
          if Ch < $10000 then
            BytesToWrite := 3
          else
            if Ch < $200000 then
              BytesToWrite := 4
            else
              if Ch < $4000000 then
                BytesToWrite := 5
              else
                if Ch <= MaximumUCS4 then
                  BytesToWrite := 6
                else
                begin
                  BytesToWrite := 2;
                  Ch := ReplacementCharacter;
                end;

      for L := BytesToWrite downto 2 do
      begin
        R[T + L - 1] := Char((Ch or ByteMark) and ByteMask);
        Ch := Ch shr 6;
      end;
      R[T] := Char(Ch or FirstByteMark[BytesToWrite]);
      Inc(T, BytesToWrite);
    end;
    SetLength(R, T - 1);
    outStream.Write(R[1], Length(R));
  end;

end;


procedure ConvertSourceFile(SrcFileName,DesFileName,
  AcciFile: string; DestType:TConvType;HTMLTitle:string='');
var
  LAccidence: TAccidence;
begin
  if not FileExists(SrcFileName) then
  begin
    MessageBox(0, PChar(pubGet('Info_FileNoFound')), PChar(pubGet(2)),
      MB_OK + MB_ICONINFORMATION);
    Exit;
  end;
  LAccidence := TAccidence.Create(AcciFile, DestType);
  try
    LAccidence.LoadFromFile(SrcFileName);
    if (DestType =ctHTML) and (HTMLTitle<>'') then
      TConvHTML(LAccidence.FConvBuilder).Title := HTMLTitle;
    LAccidence.Conversion;
    if DesFileName='' then
      if DestType = ctHTML then
        DesFileName := ChangeFileExt(SrcFileName,'.html')
      else
        DesFileName := ChangeFileExt(SrcFileName,'.rtf');
    
    LAccidence.SaveToFile(DesFileName);
  finally
    LAccidence.Free;
  end;
end;

function ConvertSource(const ASrcStr,AcciFile:string;ADestType :TConvType;
  AIsAll:Boolean = True;HTMLTitle:string=''):string;
var
  LAccidence: TAccidence;
begin
  if ASrcStr='' then  Exit;

  LAccidence := TAccidence.Create(AcciFile, ADestType);
  try
    LAccidence.Source.Text := ASrcStr ;
    if (ADestType =ctHTML) and (HTMLTitle<>'') then
      TConvHTML(LAccidence.FConvBuilder).Title := HTMLTitle;
    LAccidence.Conversion(AIsAll);     
    Result := LAccidence.Target.Text;
  finally
    LAccidence.Free;
  end;
end;

function ConvertToHead(const AAcciFile:string;ADestType:TConvType):string;
var
  LAccidence: TAccidence;
begin
  LAccidence := TAccidence.Create(AAcciFile, ADestType);
  try
    Result := LAccidence.GetConvHead ;
  finally
    LAccidence.Free;
  end;
end;
function ConvertToEnd(const AAcciFile:string;ADestType:TConvType):string;
var
  LAccidence: TAccidence;
begin
  LAccidence := TAccidence.Create(AAcciFile, ADestType);
  try
    Result := LAccidence.GetConvEnd ;
  finally
    LAccidence.Free;
  end;
end;


function RemoveLinesInHTML(ASrc :TStrings):TStrings;
var
  s :string;
  i ,j,k,m ,Digit :Integer;
begin
  Result := nil;
  if Not Assigned(ASrc) then Exit;

  i := ASrc.IndexOf('<style type="text/css">');
  if (i=-1) or (i=0) then Exit;
  m := i -1;
  s := ASrc[m];
  i :=Pos('linedigit="',s);
  if i=-1 then Exit;
  s := Copy(s,i+11,Length(s));
  i := Pos('"',s);
  if i=-1 then Exit;
  Digit := StrToIntDef(Copy(s,1,i-1),0);
  if Digit < 1 then Exit;


  j := ASrc.IndexOf('<pre>') +1;
  k := ASrc.IndexOf('</pre>') -1;
  if (j=-1) or (k =-1) or (j>=k) then Exit;
  //i := 0;
  Result := TStringList.Create;
  for i:=0 to ASrc.Count -1  do
  begin
    if m = i then Continue;
    s := ASrc[i] ;
    if i in [j..k] then
      Delete(s,1,Digit) ;
    Result.Add(s);
  end;

end;

function GetDirFiles(const Dir ,Exts :string):TStrings;  
  procedure GetFile(ADir :string);
  var Sr: TSearchRec;
  begin
    if FindFirst(ADir+'\*.*', faAnyFile, Sr)<> 0 then Exit;
    repeat
      if Sr.Attr and faDirectory = faDirectory then
      begin
        Application.ProcessMessages;  // 别让程序没响应
        if (Sr.Name <>'.') and (Sr.Name <>'..') then
          GetFile(ADir +'\'+ Sr.Name );  // 递归
      end
      else
        if LowerCase(ExtractFileExt(Sr.Name)) = LowerCase(Exts) then
          Result.Add(ADir +'\'+ Sr.Name);
      Application.ProcessMessages;  // 别让程序没响应    
    until (FindNext(Sr) <>0) or gAppConfig.Terminate;
    FindClose(Sr); 
  end;
begin
  gAppConfig.Terminate := False;
  Result := TStringList.Create;
  GetFile(Dir);
end;

function ConvertFiles(const SrcFiles :TStrings;AccFileName:string;
  ConvType:TConvType):boolean;overload;
var
  i ,Len :Integer;
  SrcFileName,DesFileName ,OutExt:string;    
  Acc : TAccidence;
begin
  Result := False;
  if Not Assigned(SrcFiles) then Exit;
  if SrcFiles.Count =0 then Exit;
  
  if ConvType = ctHtml then
    OutExt := '.html'
  else if ConvType = ctRTF then
    OutExt := '.rtf'
  else
    OutExt := '.txt';
         
  Acc := TAccidence.Create(AccFileName,ConvType); 
  try
    for i :=0 to SrcFiles.Count -1 do
    begin
      SrcFileName := SrcFiles[i];
      if FileExists(SrcFileName) then
      begin
        //Len := Length(SrcFileName) - Length(ExtractFileExt(SrcFileName));
        //DesFileName := Copy(SrcFileName,1,Len) + OutExt;
        DesFileName := ChangeFileExt(SrcFileName,OutExt); 
        Acc.ConversionToFile(SrcFileName,DesFileName);    // 同名自动替换
      end; 
    end;        
  finally
    Acc.Free;
  end;
  Result := True;  
end;
function ConvertFiles(var SrcRootDir,DesRootDir,AccFileName :String;
   ConvType:TConvType; SrcFiles :TStrings;var ProessCount:integer;
   var aSrcFileName,aDesFileName :string;
   const IsCreateHTMLToTxt:Boolean;
   const IsCopySrcFile:Boolean):boolean;overload;
var
  i ,Len :Integer;
  SrcFileName,DesFileName,
  DesPath ,PrevDesPath , OutExt:string;    
  Acc : TAccidence;
  //aWeb :TWebBrowser;
  Str,StrCMD  :TStringList;

  // 创建多级目录 Dir 要 \ 结尾
  // SysUtils.ForceDirectories(Dir: string):Boolean; 递归建立目录，按需要可创建多级目录,兼容LINUX
  function CreateMoreDir(const Dir :String):Boolean;
  var
    i:integer;
    s ,sTmp:string;
  begin
    Result := False;
    sTmp := Dir;
    i := Pos('\',sTmp);
    s := Copy(sTmp,1,i);
    sTmp := Copy(sTmp,i+1,MaxInt);
    i := Pos('\',sTmp);
    while i>0 do
    begin
      s := s + Copy(sTmp,1,i);
      sTmp := Copy(sTmp,i+1,MaxInt);       
      if Not DirectoryExists(s) then
      begin
        Result := CreateDir(s);
        if Not Result then Exit;
      end; 
      i := Pos('\',sTmp);
    end;
  end;
  // 返回相对路径 
  function GetRelPath(const BasePath,FullPath:string):string;
  var
    k : Integer;
  begin
    k :=Pos(UpperCase(BasePath),UpperCase(FullPath));
    if k =0 then
      Result := Copy(ExtractFilePath(FullPath),4,MaxInt) // D:\xx -> \xx
    else
      Result := Copy(FullPath,Length(BasePath)+1,MaxInt); 
    while (Result<>'') and (Result[1]='\') do     // 去除前 \
      Delete(Result,1,1);
  end;
begin
  Result := False;
  if SrcRootDir ='' then Exit;
  if DesRootDir ='' then Exit;
  
  if Not Assigned(SrcFiles) then Exit;
  if SrcFiles.Count =0 then Exit;
  
  if ConvType = ctHtml then
    OutExt := '.html'
  else if ConvType = ctRTF then
    OutExt := '.rtf'
  else
    OutExt := '.txt';  
  if DesRootDir[Length(DesRootDir)]<>'\' then   // 结尾 \
    //Delete(DesRootDir,Length(DesRootDir),1);
    DesRootDir := DesRootDir +'\';  
  if SrcRootDir[Length(SrcRootDir)]<>'\' then   // 结尾 \
    //Delete(SrcRootDir,Length(SrcRootDir),1);  
    SrcRootDir := SrcRootDir +'\'; 
  
  Acc := TAccidence.Create(AccFileName,ConvType); 
  if IsCreateHTMLToTxt then
  begin
  //  aWeb := TWebBrowser.Create(nil);
    //IninMainFrmWebBrowser;
    Str  := TStringList.Create;
    if IsCopySrcFile then StrCMD := TStringList.Create; 
  end;
  try
    TStringlist(SrcFiles).Sort;
    PrevDesPath :='';
    gAppConfig.Terminate := False;      
    for i :=0 to SrcFiles.Count -1 do
    begin
      SrcFileName := SrcFiles[i] ;
      if FileExists(SrcFileName) then
      begin
        DesFileName := DesRootDir + GetRelPath(SrcRootDir,SrcFileName); 
        DesPath := ExtractFilePath(DesFileName);
        if UpperCase(PrevDesPath) <> UpperCase(DesPath) then
        begin
          PrevDesPath := DesPath;
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -