commonutils.pas

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

unit CommonUtils;

{*******************************************
 * brief: 一些公共的例程和资源
 * autor: linzhenqun
 * date: 2005-10-24
 * email: [e-mail]
 * blog: http://blog.csdn.net/linzhengqun
********************************************}

interface
uses
  Windows, Messages, Classes, SysUtils, Forms, Graphics,
  SHDocVw, MSHTML{,OleCtrls},Variants, ActiveX ,IniFiles, Config;


type
  {可以自动销毁子项的类}
  TOwnerList = class(TList)
  public
    (* 覆盖该方法，释放指针的内存 *)
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
  end;
  
  // 读取资源 - 按 ID
  TpubResources = class(TObject)
  private
    FNames: TStringList;
    FValues: TStringList;
  public
    constructor Create;
    destructor Destroy; override;
    function Get(const StrName: string): String;
    procedure Add(const Ref, Str: string);
    procedure AddStrings(const Str: string);
    procedure Clear;
    procedure LoadFromFile(const FileName: string);
  end;

  
  TCharSet = Set of Char;

const
//  ST_ConvertSource = WM_USER + 100;
//  NL = #13#10;           // 回车换行 sLineBreak ; // In unit system
  Lang_EN: string = 'en';  //英语
  Lang_ZH: string = 'zh';  //简体中文
  Lang_TW: string = 'tw';  //繁体中文
  Def_FontName = 'Courier New';
  Def_FontSize = 10;

  { 源程序字符集 }
  WhiteSpaces: TCharSet = ['+', '-', '/', '*', '(', ')', ':', '=', ',', ';', '>', '<',
                           '$', '.', '#', '[', ']', '^', '@', '&', '~', '|', '%'];

  BlackSpaces: TCharSet = [#1..#32];

  StopChars: TCharSet = [#0..#32, '+', '-', '/', '*', '(', ')', ':', '=', ',', '''',
                         '{', '}', ';', '>', '<', '$', '.', '#', '[', ']', '"', '^',
                         '@', '&', '~', '|', '%'];
  // 标识符开始
  FirstIdentChar: TCharSet = ['A'..'Z', 'a'..'z', '_'];
  // 标识符
  IdentBackChars: TCharSet = ['A'..'Z', 'a'..'z', '_', '0'..'9'];
  // 数字
  DigitSet: TCharSet = ['0'..'9'];
  // 十六进制
  HexDigitSet: TCharSet = ['0'..'9', 'A'..'F', 'a'..'f'];


  PriorityClipboardFormat :array[1..27] of TIdentMapEntry =(
  (Value: CF_TEXT;            Name:'CF_TEXT'),
  (Value: CF_BITMAP;          Name:'CF_BITMAP'),
  (Value: CF_METAFILEPICT;    Name:'CF_METAFILEPICT'),
  (Value: CF_SYLK;            Name:'CF_SYLK'),
  (Value: CF_DIF;             Name:'CF_DIF'),
  (Value: CF_TIFF;            Name:'CF_TIFF'),
  (Value: CF_OEMTEXT;         Name:'CF_OEMTEXT'),
  (Value: CF_DIB;             Name:'CF_DIB'),
  (Value: CF_PALETTE;         Name:'CF_PALETTE'),
  (Value: CF_PENDATA;         Name:'CF_PENDATA'),
  (Value: CF_RIFF;            Name:'CF_RIFF'),
  (Value: CF_WAVE;            Name:'CF_WAVE'),
  (Value: CF_UNICODETEXT;     Name:'CF_UNICODETEXT'),
  (Value: CF_ENHMETAFILE;     Name:'CF_ENHMETAFILE'),
  (Value: CF_HDROP;           Name:'CF_HDROP'),
  (Value: CF_LOCALE;          Name:'CF_LOCALE'),
//  (Value: CF_MAX;             Name:'CF_MAX'),
  (Value: CF_DIBV5;           Name:'CF_DIBV5'),
  (Value: CF_MAX_XP;          Name:'CF_MAX_XP'),
  { Note:CF_MAX changes values if WINVER < 5. In order to maintain
  backwards compatability, use CF_MAX for WINVER < 5, and CF_MAX_XP for
  WINVER > 5. }
  (Value: CF_OWNERDISPLAY;    Name:'CF_OWNERDISPLAY'),
  (Value: CF_DSPTEXT;         Name:'CF_DSPTEXT'),
  (Value: CF_DSPBITMAP;       Name:'CF_DSPBITMAP'),
  (Value: CF_DSPMETAFILEPICT; Name:'CF_DSPMETAFILEPICT'),
  (Value: CF_DSPENHMETAFILE;  Name:'CF_DSPENHMETAFILE'),
  (Value: CF_PRIVATEFIRST;    Name:'CF_PRIVATEFIRST'),
  (Value: CF_PRIVATELAST;     Name:'CF_PRIVATELAST'),
  (Value: CF_GDIOBJFIRST;     Name:'CF_GDIOBJFIRST'),
  (Value: CF_GDIOBJLAST;      Name:'CF_GDIOBJLAST') );

{
resourcestring
  Msg_Error = '错识';
  Msg_Hint  = '提示';
  Msg_Warn  = '警告';
  Msg_Quest = '询问';
  //文件类型
  HTML_File = 'HTML 文件(*.html)';
  RTF_File = 'RTF 文件(*.rtf)';
  XML_File = 'XML 文件(*.xml)';
  ALL_File = '所有文件(*.*)';
  //目标文件类型转换提示信息
  Hint_DestFile_HTML = '转换源文件到 HTML 文件。';
  Hint_DestFile_RTF = '转换源文件到 RTF 文件。';

  Err_NameExist = '这个名称已存在，请输入另一个。';//The name has exist, please input another name.';
  Err_NameEmpty = '名称是空，请输入一个。';//name is empty, please input a name.';
  Err_FilePathEmpty = '文件路径是空，请输入文件路径。';//File path is empty, please input file path.';
  Err_IndexOutOfBound = '索引越界。';//The index if out of bound.';
  Err_AcciInvalide = '这是无效的词法文件。';//It is a invalied accidence file.';
  Err_NoTextFile = '这个是一个文本文件。';//It is not a text file.';
  Err_RegComServerFail = 'Register com server fail, close all explorer and try againt\n,'
    + 'or check ShellMenu.dll is in the application''s directory, or I don''t know sorry.';
  Err_UnRegComServerFail = 'UnRegister com server fail, close all explorer and try againt\n,'
    + 'or check ShellMenu.dll is in the application''s directory, or I don''t know sorry.';
  Info_FileNoFound = '这个文件没找到。';//The file is not found!';
  Info_AcciNoFound = '词法文件没找到。';//'The accidence file not found!';
  Info_SetSrcFile = '请打开要将转换的源代码文件。';//'Please set the source file to convert!';
  Info_SetDesFile = '请设定目标文件保存路径。';//'Please set the destination file to save!';
}

// 全局访问资源  
function pubResources: TpubResources;
// 按ID号得到资源字串
function pubGet(ID: Integer): string;overload;
function pubGet(Name: string): string;overload;

// 加载资源到系统
procedure LoadResources;

// 得到 ini/xml 文件配置信息
// Section 小节,Default 默认值 
// 下面 a/b 二选一. AttrName优先
// a.AttrName 第二层的属性名称，返回名称的值;
// b.NameValue 第三层的Name值，返回Value的值
function GetCfgValue(const Section, AttrName,NameValue: string;
  const Default: string=''; const AppSection:string=AppSections;
 IsCreate:boolean=True):string;
//function GetAttrCfgValue(const Section, AttrName: string;const Default: string='';
//  const AppSection:string=AppSections;IsCreate:boolean=True):string;

(* 取得一个数字的位数 *)
function GetDigitFromNum(ANum: Integer): Integer;

(* TColor转成网页的十六进制颜色 *)
function TColorToHTMLColor(Color : TColor) : string;

(* 网页的十六进制颜色转成TColor *)
function HTMLColorToTColor(sColor : string) : TColor;

(* 检测一个字符是否为符号 除了空格 *)
function IsSymbol(C: Char): Boolean;

// 是否标识符
//function IsIdentifier(C:Char):Boolean;

(* 判断是否为文本文件 *)
function IsTextFile(FileName: string): Boolean;

(* 取得相对于本程序的路径，找不到返回绝对路径 *)
function GetRelativePath(FilePath: string): string;

(* 取得相对于本程序绝对路径 *)
function GetAbsolutePath(FilePath: string): string;

(* 取得版本号 *)
function GetVersionInfo(Full: Boolean): string;

(* 短文件名变为长文件名 *)
function ShortToLongFileName(FileName: string): string;

(* 取得当前模块的全文件名 *)
function GetModuleFileName: string;

(* 注册COM服务器 *)
procedure RegisterComServer(const DLLName: string);

(* 注销COM服务器 *)
procedure UNRegisterComServer(const DLLName: string);


// 写 HTML 源码到 WebBrowser 控件
procedure StreamToWebBrowser(AWeb :TWebBrowser;AStream :TStream);
procedure StringToWebBrowser(AWeb :TWebBrowser;AString :string);
procedure WriteWebBrowser(AWeb :TWebBrowser;AHTML :string);

// 取控件 WebBrowser 控件中的 HTML 源码
function GetWebSource(AWeb :TWebBrowser;IsHTMLSource:boolean=True):string;
procedure IninMainFrmWebBrowser;
function GetWebSourceText(const SrcFileName:string):string;
function getMainWeb:TWebBrowser;

// ShowModal 表单
procedure FormShowModal(FormClass: TFormClass);
// 显示消息提示
procedure ShowDlg(Msg :string;Flag :integer =MB_OK;
  Icon :Integer=MB_ICONINFORMATION);
// 替换字串的的 #13 为 #13#10
function ReplaceEnter(const s :string):string;

function GetCharSet:string;


function gAppConfig :TAppConfig;

implementation

uses Math, ComObj, MainFrm;

var
  FResources: TpubResources = nil;  // 公共资源读取对象
  uAppConfig: TAppConfig =nil;      // 程序配置文件
  

function gAppConfig :TAppConfig;
begin
  if uAppConfig = nil then
    uAppConfig := TAppXMLConfig.Create(GetAbsolutePath('Config_2.xml'));
  Result := uAppConfig;
end;

{ TOwnerList }
procedure TOwnerList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  inherited;
  if (Action = lnDeleted) and (Ptr <> nil) then
    Dispose(Ptr);
end;

{ Common Function/Procedure }

function GetDigitFromNum(ANum: Integer): Integer;
begin
  Result := 0;
  repeat
    Inc(Result);
    ANum := ANum div 10;
  until ANum = 0;
end;

function TColorToHTMLColor(Color : TColor) : string;
begin
  Result :='#' +
    IntToHex(GetRValue(Color), 2) +
    IntToHex(GetGValue(Color), 2) +
    IntToHex(GetBValue(Color), 2);
end;

function HTMLColorToTColor(sColor : string) : TColor;
begin
  Result :=
    RGB(
      StrToInt('$'+Copy(sColor, 2, 2)),
      StrToInt('$'+Copy(sColor, 4, 2)),
      StrToInt('$'+Copy(sColor, 6, 2))
    );
end;

function IsSymbol(C: Char): Boolean;
begin
  Result := C in ['!'..'/',':'..'@','['..'`','{'..'~'];
  // 字符32-126:空格!"#$%&'()*+,-./0123456789:;<=>?@
  // ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~
  // 符号：['!'..'/',':'..'@','['..'`','{'..'~']  (不含空格)
  // 数字：['0'..'9'] 标识串：['A'..'Z','a'..'z','_','0'..'9'] (数字不能开头) 
  //-----------
  //if C in ['`', '~', '!', '@', '#', '$', '%', '^', '&', '*', '(', ')', '-',
  //  '+', '\', '|', '=', '{', '}', '[', ']', ':', ';', '''', '"', '<', ',',
  //  '>', '.', '/', '?'] then
  //  Result := True;
end;

function IsTextFile(FileName: String): Boolean;
var
  FS: TFileStream;
  i, size: integer;
  ByteData: Byte;
begin
  // 只判断前1K的字节，准确率应该很高了。
  Result := false;
  if FileExists(FileName) then
  begin
    FS := TFileStream.Create(FileName, fmOpenRead);
    Result := true;
    i := 0;
    size := IfThen(FS.Size > 1024, 1024, FS.Size);
    While (i < size) and Result do
    begin
      Fs.Read(ByteData, 1);
      Result := ByteData <> 0;   // 是否包含 #0
      inc(i)
    end;
    Fs.Free;
  end;
end;

function GetRelativePath(FilePath: string): string;
var
  S1, S2: string;
  i: Integer;
begin
  S1 := ExtractFilePath(ParamStr(0));
  S2 := ExtractFilePath(FilePath);
  i := Pos(S1, S2);
  if i = 0 then
    Result := FilePath
  else begin
    Result := Copy(FilePath, length(S1) + 1, length(FilePath));
  end;
end;

function GetAbsolutePath(FilePath: string): string;
begin
  // 注意，这里的相对路径是相对于执行文件的
  if ExtractFileDrive(FilePath)= '' then
    Result := ExtractFilePath(ParamStr(0)) + FilePath
  else
    Result := FilePath;
end;

function GetVersionInfo(Full: Boolean): string;
var
  InfoSize, Wnd: DWORD;
  VerBuf: Pointer;
  FI: PVSFixedFileInfo;
  VerSize: DWORD;
begin
  Result := '';
  InfoSize := GetFileVersionInfoSize(PChar(Application.ExeName), Wnd);
  if InfoSize > 0 then
  begin
    GetMem(VerBuf, InfoSize);
    try
      if GetFileVersionInfo(PChar(Application.ExeName), Wnd, InfoSize, VerBuf) then
        if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then
          if Full then
            Result := Format('%d.%d.%d.%d', [HIWORD(FI.dwFileVersionMS),
              LOWORD(FI.dwFileVersionMS), HIWORD(FI.dwFileVersionLS),
              LOWORD(FI.dwFileVersionLS)])
          else
            Result := Format('%d.%d', [HIWORD(FI.dwFileVersionMS),
              LOWORD(FI.dwFileVersionMS)]);
    finally
      FreeMem(VerBuf);
    end;
  end;
end;

function ShortToLongFileName(FileName: string): string;
var
  FindData: TWin32FindData;
  Search: THandle;
begin
  Result := '';

  // Strip off one directory level at a time starting with the file name
  // and store it into the result. FindFirstFile will return the long file
  // name from the short file name.
  while (True) do
  begin
    Search := Windows.FindFirstFile(PChar(FileName), FindData);
    if Search = INVALID_HANDLE_VALUE then
      Break;

    Result := string('\') + FindData.cFileName + Result;
    FileName := ExtractFileDir(FileName);
    Windows.FindClose(Search);

    // Found the drive letter followed by the colon.
    if Length(FileName) <= 2 then
      Break;
  end;

  Result := ExtractFileDrive(FileName) + Result;
end;

function GetModuleFileName: string;
var
  Buffer: array[0..261] of Char;
begin
  SetString(Result, Buffer, Windows.GetModuleFileName(HInstance,
    Buffer, SizeOf(Buffer)));
  Result := ShortToLongFileName(Result);
end;

procedure CallRegisterComAPI(const DLLName, ProcName: string);
type
  TRegProc = function: HResult; stdcall;
var
  Handle: THandle;
  RegProc: TRegProc;
begin
  Handle := SafeLoadLibrary(DLLName);
  if Handle <= HINSTANCE_ERROR then
    raise Exception.CreateFmt('%s: %s', [SysErrorMessage(GetLastError), DLLName]);
  try
    RegProc := GetProcAddress(Handle, PChar(ProcName));
    if Assigned(RegProc) then OleCheck(RegProc) else RaiseLastOSError;
  finally
    FreeLibrary(Handle);
  end;
end;

procedure RegisterComServer(const DLLName: string);
begin
  CallRegisterComAPI(DLLName, 'DllRegisterServer');
end;

procedure UnRegisterComServer(const DLLName: string);
begin
  CallRegisterComAPI(DLLName, 'DllUnregisterServer');
end;


procedure StreamToWebBrowser(AWeb :TWebBrowser;AStream :TStream);
var
  Buffer : string;
begin
  AStream.Seek(0,soBeginning);
  SetLength(Buffer,AStream.Size);
  AStream.Read(Buffer[1],AStream.Size);
  StringToWebBrowser(AWeb,Buffer);
  Setlength(Buffer,0);
end;
procedure StringToWebBrowser(AWeb :TWebBrowser;AString :string);
var
  ArrStr,A : OleVariant;
  IDoc : IHtmlDocument2;
  Autf8 : String;
begin
  ArrStr :=VarArrayCreate([0,0],varVariant); //
  //VarType(ArrStr) := vtPChar;
  //Autf8 := UTF8Decode(AString);
  //Autf8 :=Utf8ToAnsi(UTF8String(AString));
 { with TStringList.Create do
  try
    LoadFromFile('E:\Documents and Settings\tssi\桌面\aaa.htm');