捐赠 | 广告 | 注册 | 发布 | 上传 | 关于我们    
  沪ICP备05001939号 DELPHI盒子 | 盒子论坛 | 盒子文章 | 盒子问答悬赏 | 最新更新 | 论坛检索 | 下载中心 | 高级搜索    
  精品专区 | 繁體中文 | 奖励公告栏 | 直通车账号登陆 | 关闭GOOGLE广告 | 临时留言    
盒子资源分类
全部展开 - 全部合拢
个人收集及编写的一个通用函数集
关键字:UC 通用函数集 Function 字符串
来 自:原创
平 台:Win9x,Win2k/XP/NT,Win2003 下载所需:0 火柴
深浅度:初级 完成时间:2003/4/18
发布者:Longmaster 发布时间:2005/11/8
编辑器:DELPHI7 语  种:简体中文
分 类:其他 下载浏览:0/26891
加入到我的收藏
下载错误报错
登陆以后才能下载
 用户名:
 密 码:
自动登陆(30天有效)
无图片
(*//
标题:UC函数单元
说明:通用函数
日期:2002-10-25
设计:Zswang
扩展:HongzhiK
扩展目期:2003-4-18
版权:Longmaster
//*)

//*******Begin 修改日志*******//
(*
扩展:HongzhiK
扩展目期:2003-6-28
内容:
    增加了快速字符串处理单元。大量的字符串处理函数。
*)
//*******End 修改日志*******//

unit FuncUnit;

interface
{$I Head.inc}
uses Windows, SysUtils, Graphics, Classes, registry, Forms, StdCtrls, Consts,
Dialogs, Controls, ShlObj;

type
  TFileVersionInfomation = record
    rCommpanyName: string;
    rFileDescription: string;
    rFileVersion: string;
    rInternalName: string;
    rLegalCopyright: string;
    rLegalTrademarks: string;
    rOriginalFileName: string;
    rProductName: string;
    rProductVersion: string;
    rComments: string;
    rVsFixedFileInfo: VS_FIXEDFILEINFO;
    rDefineValue: string;
  end;
  
const
  cBoolChar: array[Boolean] of Char = ('F', 'T');
  cFrame = 1;
function HexToStr(mHex: string): string;
function StrToHex(mStr: string): string;

function StrLeft(const mStr: string; mDelimiter: string): string;
function StrRight(const mStr: string; mDelimiter: string): string;
function ListCount(mList: string; mDelimiter: string = ','): Integer;
function ListValue(mList: string; mIndex: Integer; mDelimiter: string = ','): string;

function SubStrConut(mStr: string; mSub: string): Integer;

function WideStringToLines(mStr: WideString): string;

function StringToDisplay(mString: string): string;
function DisplayToString(mDisplay: string): string;

function GetFileVersionInfomation(mFileName: TFileName;
  var nFileVersionInfomation: TFileVersionInfomation;
  mDefineName: string = '): Boolean;


function IsFocusd(mHandle: THandle): Boolean; { 返回窗体是否具有焦点 }

function StrToSet(mStr: string): TSysCharSet;

type
  TOnOff     = (TofOff,TofOn);
  TCharSegmentSet = set of 0{1}..7;
  TCharSegment = TCharSegmentSet;


//////////自定义新涵数hongzhiK-start//////////
//显示数字在一个框里,类似于显示出电子表效果,超酷
//强列推建
procedure ShowDigiInRect(Canvas: TCanvas; mRect: TRect; str : string);
//////////快速位图翻转函数//////////
function Turnbmp1(mSource: TBitmap; Rotate: integer): Boolean;
function BitmapRotate90(mSource: TBitmap): Boolean;
function BitmapRotate180(mSource: TBitmap): Boolean;
function BitmapRotate270(mSource: TBitmap): Boolean;
//////////快速位图翻转函数//////////
//**********四国军棋内部用的**********//
  function Turnbmp(mSource: TBitmap; Rotate: integer): Boolean;
{$IFNDEF K_CB5}
  procedure DrawBlockFrameSiGuo(vleft,vtop,vright,vbuttom : integer; Canvas:TCanvas);overload;//画小块的边框
  procedure DrawBlockFrameSiGuo(mRect : TRect; Canvas:TCanvas); overload;//画小块的边框
//**********四国军棋内部用的**********//
  //////////几个画块函数公用//////////
  procedure DrawBlockFrameSmall(vleft,vtop,vright,vbuttom : integer; DrawColor : TColor;Canvas:TCanvas);overload;//画小块的边框
  procedure DrawBlockFrameSmall(mRect : TRect; DrawColor : TColor;Canvas:TCanvas); overload;//画小块的边框

  procedure DrawBlockFrameOnner(vleft,vtop,vright,vbuttom : integer; DrawColor : TColor;Canvas:TCanvas);overload;//画小块的边框
  procedure DrawBlockFrameOnner(mRect : TRect; DrawColor : TColor;Canvas:TCanvas); overload;//画小块的边框
  procedure DrawBlockFrameInner(vleft,vtop,vright,vbuttom : integer; DrawColor : TColor;Canvas:TCanvas);overload;//画小块的边框
  procedure DrawBlockFrameInner(mRect : TRect; DrawColor : TColor;Canvas:TCanvas); overload;//画小块的边框
  //////////几个画块函数//////////
{$ENDIF}
  function GetColorA(chint : boolean; vcolor : TColor) : TColor;  //改变阴影的函数
  function GetColor(chint : boolean; vcolor : TColor) : TColor;  //改变阴影的函数主要用于方块中
//////////几个字串转换函数//////////

  function GetSubStr(Str : string; index : integer):string;
//  procedure StrToUser(str : string; var FUser : TVCLUser);
//  function UserToStr(FUser : TVCLUser): string;
  function StrBinToStr(strbin: string): string; //二进制转为字串
  function StrToStrBin(str: string): string; //字串转为二进制
//////////几个字串转换函数//////////
//////////新定义//////////
    //写入
  function mMove(i : integer):string;overload;
  function mMove(i : int64):string;overload;
  function mMove(i : boolean):string;Overload;
  function mMove(i : Word):string;Overload;
  function mMove(i : Byte):string;Overload;
  function mMove(p : Pchar; Size: integer): string;Overload;
  //读出
  procedure mMove(var i : integer; var Source: string);overload;
  procedure mMove(var i : int64; var Source: string);overload;
  procedure mMove(var i : boolean; var Source: string);overload;
  procedure mMove(var i : Word; var Source: string);overload;
  procedure mMove(var i : Byte; var Source: string);overload;
  function InputBoxEx(const ACaption, APrompt, ADefault: string): string;
  function MaskForm(const imask : Byte): Byte;

//////////自定义新涵数hongzhiK-end;//////////
(**********又是几个新收集函数**********)


(**********又是几个新收集函数**********)
//////////快速字符串//////////
const
  cHexChars = '0123456789ABCDEF';

Type
  TFastPosProc = function (const aSource, aFind; const aSourceLen, aFindLen : integer) : Pointer;
  TFastPosIndexProc = function (const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

procedure FastCharMove(const Source; var Dest; Count : Integer);
function FastCharPos(const aSource : String; const C: Char; StartPos : Integer) : Integer;
function FastCharPosNoCase(const aSource : String; C: Char; StartPos : Integer) : Integer;
function FastPos(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastPosNoCase(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastPosBack(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastPosBackNoCase(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastReplace(const aSourceString : String; const aFindString, aReplaceString : String;
  CaseSensitive : Boolean = False) : String;
function SmartPos(const SearchStr,SourceStr : String;
          const CaseSensitive : Boolean = TRUE;
          const StartPos : Integer = 1;
          const ForwardSearch : Boolean = TRUE) : Integer;

//pointer routines, which are faster
function FastmemPos(const aSource, aFind; const aSourceLen, aFindLen : integer) : Pointer;
function FastmemPosNC(const aSource, aFind; const aSourceLen, aFindLen : integer) : Pointer;

function Decrypt(const S: String; Key: Word): String;
function Encrypt(const S: String; Key: Word): String;
function ExtractHTML(S : String) : String;
function ExtractNonHTML(S : String) : String;
function CopyStr(const aSourceString : String; aStart, aLength : Integer) : String;
function GetValue(ValueName, Text : String) : String;
function HexToInt(aHex : String) : int64;
function LeftStr(const aSourceString : String; Size : Integer) : String;
function StringMatches(Value, Pattern : String) : Boolean;
function MissingText(Pattern, Source : String; SearchText : String = '?') : String;
function RandomFileName(aFilename : String) : String;
function RandomStr(aLength : Longint) : String;
function ReverseStr(const aSourceString : String) : String;
function RightStr(const aSourceString : String; Size : Integer) : String;
function RGBToColor(aRGB : String) : TColor;
function StringCount(const aSourceString, aFindString : String; Const CaseSensitive : Boolean = TRUE) : Integer;
function UniqueFilename(aFilename : String) : String;
function URLToText(aValue : String) : String;
function WordAt(Text : String; Position : Integer) : String;

procedure Split(aValue : String; aDelimiter : Char; Result : TStrings);

//////////快速字符串//////////
//////////新的字符串涵 数收集//////////
{========== String Utils ==========}

function slash(value:string):string;
{ensures that value has '\' as last character (for directory strings)}

function capfirst(value:string):string;
{Capitalise first character of each word, lowercase remaining chars}
{example: capfirst('bOrLANd delPHi FOR windOWs') = 'Borland Delphi For Windows'}

function striptags(value:string):string;
{strip HTML tags from value}
{example: striptags('<TR><TD Align="center">Hello World</TD>') = 'Hello World'}

function replace(str,s1,s2:string;casesensitive:boolean):string;
{replace all incidences of s1 in str with s2}
{example: replace('We know what we want','we','I',false) = 'I Know what I want'}

function CopyFromChar(s:string;c:char;l:integer):string;
{copy l characters from string s starting at first incidence of c}
{example: Copyfromchar('Borland Delphi','a',3) = 'and'}


{========== System Utils ==========}
function getwinsysdir:string;
{returns Windows System Path (inc drive)}
{example: getwinsysdir = 'C:\WINDOWS\SYSTEM\'}

function getwindir:string;
{returns windows directory path (inc Drive)}
{example: getwindir = 'C:\WINDOWS\'}

function getinstalldir:string;
{returns install directory of EXE using this library}
{example: getinstalldir = 'C:\PROGRAM FILES\BORLAND\DELPHI\DEMOS\'}

function getregvalue(root:integer;key,value:string):string;
{reads a registry value}
{example: getregvalue(HKEY_LOCAL_MACHINE,'network\logon\','username') = 'Eddie Bond'}

function getfiledate(filename:string):Tdatetime;
{returns a file's date in TDateTime format}


{========== Arithmetic Utils ==========}

function StrToFloatDef(const s:string;def:Extended):Extended;
{converts S into a number. If S is invalid, returns the number passed in Def.}
{example: strtofloatdef('$10.25',0) = 0}

function VolSphere(radius:single):extended;
{volume of sphere of given radius}

function AreaSphere(radius:single):extended;
{surface area of sphere of given radius}

function VolCylinder(radius,height:single):extended;
{volume of cylinder of given radius and height}

function AreaCylinder(radius,height:single):extended;
{surface area of cylinder of given radius and height}

function MinExt(const A:array of Extended):Extended;
{returns minimum value of an array of extended}

function MaxExt(const A:array of Extended):Extended;
{returns maximum value of an array of extended}

function MinInteger(const A:array of Integer):Integer;
{returns minimum value of an array of integers}

function MaxInteger(const A:array of integer):Integer;
{returns maximum value of an array of integers}

function InverseSum(const a:array of single):single;
{solves formulae of type 1/r = 1/a + 1/b +...1/n (eg electrical resistance in parallel)}

{========== Financial Utils ==========}

function MarkUp(profit:single):single;
{returns markup percentage required to return a profit of profit percent}
{example: MarkUp(25) = 20 }

function SellingPrice(net:double;markup:single):double;
{returns selling price after adding markup percent to net}
{example: SellingPrice(199.50,22.5) = 244.3875}

function NetPrice(gross:double;taxrate:single):double;
{returns the net value of an item of gross value containing tax at taxrate percent}
{example: NetPrice(199.99,17.5) = 170.204255319149}
//////////新的字符串涵 数收集//////////
//==========系统路径==========//
Function GetApplicationExeName: string;
Function GetApplicationShortExeName: string;
Function GetWindowsDir: string;  //c:\winnt
Function GetSystemDir: string;  //c:\winnt\system32
Function GetTempDir: string;  //应用程序的路径 如D:/winnt/temp
Function GetApplicationPath:String; //应用程序的路径 如D:/feng/
Function GetApplicationDir:String; //应用程序的路径 如D:/feng
Function GetCurrentDir: string;  //应用程序的路径 如D:/feng
function GetProgramsDir: string;//程序组目录
function GetMy_DocumentsDir: string;//我的文档       //如C:\My Documents
function GetFavoritesDir: string;
function GetSystemFolderDir(mFolder: Integer): string;
//==========系统路径==========//
var
  vModuleVersionInfomation: TFileVersionInfomation;

implementation

uses Math;

function IsFocusd(mHandle: THandle): Boolean;
var
  vHandle: THandle;
begin
  vHandle := GetFocus;
  while (mHandle <> vHandle) and (vHandle <> 0) do
    vHandle := GetParent(vHandle);
  Result := mHandle = vHandle;
end;

function StrToSet(mStr: string): TSysCharSet;
var
  I: Integer;
begin
  Result := [];
  for I := 1 to Length(mStr) do
    Include(Result, mStr[I]);
end; { StrToSet }

function HexToStr(mHex: string): string;
var
  I: Integer;
begin
  Result := ';
  for I := 1 to Length(mHex) div 2 do
    Result := Result + Chr(StrToIntDef('$' + Copy(mHex, I * 2 - 1, 2), 0));
end; { HexToStr }

function StrToHex(mStr: string): string;
var
  I: Integer;
begin
  Result := ';
  for I := 1 to Length(mStr) do
    Result := Format('%s%.2x', [Result, Ord(mStr[I])]);
end; { StrToHex }

function StrLeft(const mStr: string; mDelimiter: string): string;
{ 返回左分隔字符串 }
begin
  Result := Copy(mStr, 1, Pos(mDelimiter, mStr) - 1);
end; { StrLeft }

function StrRight(const mStr: string; mDelimiter: string): string;
begin
  if Pos(mDelimiter, mStr) > 0 then
    Result := Copy(mStr, Pos(mDelimiter, mStr) + Length(mDelimiter), MaxInt)
  else Result := ';
end; { StrRight }

function ListCount(mList: string; mDelimiter: string = ','): Integer;
{ 返回列表数 }
var
  I, L: Integer;
begin
  Result := 0;
  if mList = ' then Exit;
  L := Length(mList);
  I := Pos(mDelimiter, mList);
  while I > 0 do begin
    mList := Copy(mList, I + Length(mDelimiter), L);
    I := Pos(mDelimiter, mList);
    Inc(Result);
  end;
  Inc(Result);
end; { ListCount }

function ListValue(mList: string; mIndex: Integer; mDelimiter: string = ','): string;
{ 返回列表指定位置的元素 }
var
  I, L, K: Integer;
begin
  L := Length(mList);
  I := Pos(mDelimiter, mList);
  K := 0;
  Result := ';
  while (I > 0) and (K <> mIndex) do begin
    mList := Copy(mList, I + Length(mDelimiter), L);
    I := Pos(mDelimiter, mList);
    Inc(K);
  end;
  if K = mIndex then Result := StrLeft(mList + mDelimiter, mDelimiter);
end; { ListValue }

function SubStrConut(mStr: string; mSub: string): Integer;
{ 返回子字符串出现的次数 }
begin
  Result := Length(mStr) - Length(StringReplace(mStr, mSub, ', [rfReplaceAll]));
end; { SubStrConut }

function WideStringToLines(mStr: WideString): string;
var
  I: Integer;
begin
  Result := ';
  for I := 1 to Length(mStr) do
    Result := Result + #13#10 + mStr[I];
  Delete(Result, 1, 2);
end; { WideStringToLines }

function StringToDisplay(mString: string): string;
var
  I: Integer;
  S: string;
begin
  Result := ';
  S := ';
  for I := 1 to Length(mString) do
    if mString[I] in [#32..#127] then
      S := S + mString[I]
    else begin
      if S <> ' then begin
        Result := Result + QuotedStr(S);
        S := ';
      end;
      Result := Result + Format('#$%x', [Ord(mString[I])]);
    end;
  if S <> ' then Result := Result + QuotedStr(S);
end; { StringToDisplay }

function DisplayToString(mDisplay: string): string;
var
  I: Integer;
  S: string;
  B: Boolean;
begin
  Result := ';
  B := False;
  mDisplay := mDisplay;
  for I := 1 to Length(mDisplay) do
    if B then case mDisplay[I] of
      '': begin
        if S <> ' then Result := Result + StringReplace(S, ''', '', [rfReplaceAll]);
          if Copy(mDisplay, I + 1, 1) = '' then Result := Result + '';
          S := ';
          B := False;
        end;
      else S := S + mDisplay[I];
      end
    else case mDisplay[I] of
      '#', '': begin
        if S <> ' then Result := Result + Chr(StrToIntDef(S, 0));
        S := ';
        B := mDisplay[I] = '';
      end;
      '$', '0'..'9', 'a'..'f', 'A'..'F': S := S + mDisplay[I];
    end;
  if (not B) and (S <> ') then Result := Result + Chr(StrToIntDef(S, 0));
end; { DisplayToString }

function GetFileVersionInfomation(mFileName: TFileName;
  var nFileVersionInfomation: TFileVersionInfomation;
  mDefineName: string = '): Boolean;
var
  vHandle: Cardinal;
  vInfoSize: Cardinal;
  vVersionInfo: Pointer;
  vTranslation: Pointer;
  vVersionValue: string;
  vInfoPointer: Pointer;
begin
  Result := False;
  vInfoSize := GetFileVersionInfoSize(PChar(mFileName), vHandle); //取得文件版本信息空间及资源句柄
  FillChar(nFileVersionInfomation, SizeOf(nFileVersionInfomation), 0); //初始化返回信息
  if vInfoSize <= 0 then Exit; //安全检查

  GetMem(vVersionInfo, vInfoSize); //分配资源
  with nFileVersionInfomation do try
    if not GetFileVersionInfo(PChar(mFileName),
      vHandle, vInfoSize, vVersionInfo) then Exit;
    VerQueryValue(vVersionInfo, '\VarFileInfo\Translation',
      vTranslation, vInfoSize);
    vVersionValue := Format('\StringFileInfo\%.4x%.4x\',
      [LOWORD(Longint(vTranslation^)), HIWORD(Longint(vTranslation^))]);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'CompanyName'),
      vInfoPointer, vInfoSize);
    rCommpanyName := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'FileDescription'),
      vInfoPointer, vInfoSize);
    rFileDescription := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'FileVersion'),
      vInfoPointer, vInfoSize);
    rFileVersion := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'InternalName'),
      vInfoPointer, vInfoSize);
    rInternalName := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'LegalCopyright'),
      vInfoPointer, vInfoSize);
    rLegalCopyright := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'LegalTrademarks'),
      vInfoPointer, vInfoSize);
    rLegalTrademarks := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'OriginalFileName'),
      vInfoPointer, vInfoSize);
    rOriginalFileName := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'ProductName'),
      vInfoPointer, vInfoSize);
    rProductName := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'ProductVersion'),
      vInfoPointer, vInfoSize);
    rProductVersion := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, PChar(vVersionValue + 'Comments'),
      vInfoPointer, vInfoSize);
    rComments := PChar(vInfoPointer);
    VerQueryValue(vVersionInfo, '\', vInfoPointer, vInfoSize);
    rVsFixedFileInfo := TVSFixedFileInfo(vInfoPointer^);
    if mDefineName <> ' then begin
      VerQueryValue(vVersionInfo, PChar(vVersionValue + mDefineName),
        vInfoPointer, vInfoSize);
      rDefineValue := PChar(vInfoPointer);
    end else rDefineValue := ';
  finally
    FreeMem(vVersionInfo, vInfoSize);
  end;
  Result := True;
end; { GetFileVersionInfomation }
//=======Begin 位图翻转函数
function Turnbmp(mSource: TBitmap; Rotate: integer): Boolean;
begin
  Result := false;
  case Rotate of
    1: if BitmapRotate90(mSource) then Result := true;
//    2: if BitmapRotate180(mSource) then Result := true;
    3: if BitmapRotate270(mSource) then Result := true;
  end;
end;

function Turnbmp1(mSource: TBitmap; Rotate: integer): Boolean;
begin
  Result := false;
  case Rotate of
    1: if BitmapRotate90(mSource) then Result := true;
    2: if BitmapRotate180(mSource) then Result := true;
    3: if BitmapRotate270(mSource) then Result := true;
  end;
end;

function BitmapRotate90(mSource: TBitmap): Boolean;
var
  I, J,  BITS, SIZE: Integer;
  A: PByteArray;
  ms :TMemoryStream;
begin
  Result := False;
  if not Assigned(mSource) then Exit;
  case mSource.PixelFormat of
    pf8bit : BITS := 1;
    pf16bit: BITS := 2;
    pf24bit: BITS := 3;
    pf32bit: BITS := 4;
    else Exit;
  end;
  SIZE := mSource.Width;
  ms := TMemoryStream.Create;
  try
    for I := 0 to mSource.Height - 1 do
    begin
       A  := mSource.ScanLine[I];
       ms.WriteBuffer(A^,SIZE * BITS);
    end;
    ms.Position := 0;
    mSource.Width := mSource.Height;
    mSource.Height := SIZE;
    for J := (mSource.Width - 1) downto 0 do
    for I := 0 to mSource.Height - 1 do
    begin
      A := mSource.ScanLine[I];
      ms.ReadBuffer(A[J * BITS], BITS);
    end;
  finally
    ms.Free;
  end;
  Result := True;
end; { BitmapRotate90 }

function BitmapRotate180(mSource: TBitmap): Boolean;
var
  I, J, BITS, SIZE: Integer;
  A: PByteArray;
  ms :TMemoryStream;
begin
  Result := False;
  if not Assigned(mSource)  then Exit;
  case mSource.PixelFormat of
    pf8bit : BITS := 1;
    pf16bit: BITS := 2;
    pf24bit: BITS := 3;
    pf32bit: BITS := 4;
    else Exit;
  end;
  SIZE := mSource.Width;
  ms := TMemoryStream.Create;
  try
    for I := 0 to mSource.Height - 1 do
    begin
       A  := mSource.ScanLine[I];
       ms.WriteBuffer(A^,SIZE * BITS);
    end;
    ms.Position := 0;
    for I := (mSource.Height - 1) downto 0 do
    begin
       A := mSource.ScanLine[I];
       for J := (mSource.Width - 1) downto 0 do
         ms.ReadBuffer(A[J * BITS], BITS);
    end;
  finally
    ms.free;
  end;
  Result := True;
end; { BitmapRotate180 }

function BitmapRotate270(mSource: TBitmap): Boolean;
var
  I, J, BITS, SIZE: Integer;
  A: PByteArray;
  ms :TMemoryStream;
begin
  Result := False;
  if not Assigned(mSource) then Exit;
  case mSource.PixelFormat of
    pf8bit : BITS := 1;
    pf16bit: BITS := 2;
    pf24bit: BITS := 3;
    pf32bit: BITS := 4;
    else Exit;
  end;
  SIZE := mSource.Width;
  ms := TMemoryStream.Create;
  try
    for I := 0 to mSource.Height - 1 do
    begin
       A  := mSource.ScanLine[I];
       ms.WriteBuffer(A^,SIZE * BITS);
    end;
    ms.Position := 0;
    mSource.Width := mSource.Height;
    mSource.Height := SIZE;
    for J := 0 to mSource.Width - 1 do
    for I := (mSource.Height - 1) downto 0 do
    begin
      A := mSource.ScanLine[I];
      ms.ReadBuffer(A[J * BITS], BITS);
    end;
  finally
    ms.Free;
  end;
  Result := True;
end; { BitmapRotate270 }
//=======End 位图翻转函数
function StrBinToStr(strbin: string): string; //二进制转为字串
var
  c: byte;
  i,bindex: integer;
  str : string;
begin
  str := ';
  c := $0;
  i := Length(strbin) mod 8;
  if i <> 0 then
  for bindex := 1 to 8-i do strbin := strbin + '0';
  bindex := 1;
  for i := 1 to Length(strbin) do
  begin
    if bindex > 8 then begin
      str := str + Char(c);
      c := $0;
      bindex := 1;
    end;
    c := byte(c shl 1);
    if strbin[i] = '1' then c:= c or $1;
    Inc(bindex);
  end;
  if bindex <> 1 then str := str + Char(c);
  Result := str;
end;
function StrToStrBin(str: string): string; //字串转为二进制
var
  i, j: integer;
  binstr: string;
  c : Byte;
begin
  binstr := ';
  for i := 1 to Length(str) do
  begin
    c:= Byte(str[i]);
    for j := 1 to 8 do begin
      if (c and $80) <> $00 then
        binstr:= binstr + '1'
      else
        binstr := binstr + '0';
      c := Byte(c shl 1);
    end
  end;
  Result := binstr;
end;

procedure RGBtoHSL(R,G,B:Integer;var H,S,L:Integer);
var
 Delta : Double;
 CMax,CMin : Double;
 Red,Green,Blue,Hue,Sat,Lum : Double;
begin
 Red := R/255;
 Green := G/255;
 Blue := B/255;
 CMax := Max(Red,Max(Green,Blue));
 CMin := Min(Red,Min(Green,Blue));
 Lum := (CMax+CMin)/2;
 if CMax = CMin then begin
   Sat := 0;
   Hue := 0;
 end
 else begin
   if Lum < 0.5 then Sat := (CMax-CMin)/(CMax+CMin)
   else Sat := (cmax-cmin)/(2-cmax-cmin);
   delta := CMax-CMin;
   If Red = CMax then Hue := (Green-Blue)/Delta
   else if Green = CMax then Hue := 2+(Blue-Red)/Delta
   else Hue := 4.0+(Red-Green)/Delta;
   Hue := Hue / 6;
   If Hue < 0 then Hue := Hue + 1;
 end;
 H := Round(Hue*360);
 S := Round(Sat*100);
 L := Round(Lum*100);
end;

procedure HSLtoRGB(H,S,L:Integer;var R,G,B:Integer);
var
 Sat,Lum : Double;
begin
 R := 0;
 G := 0;
 B := 0;
 if (H < 360) and (H >= 0) and (S <= 100) and (S >= 0) and (L <= 100) and (L >= 0) then begin
   if H <=60 then begin
     R := 255;
     G := Round((255/60)*H);
     B := 0;
   end
   else if H <=120 then begin
     R := Round(255-(255/60)*(H-60));
     G := 255;
     B := 0;
   end
   else if H <=180 then begin
     R := 0;
     G := 255;
     B := Round((255/60)*(H-120));
   end
   else if H <=240 then begin
     R := 0;
     G := Round(255-(255/60)*(H-180));
     B := 255;
   end
   else if H <=300 then begin
     R := Round((255/60)*(H-240));
     G := 0;
     B := 255;
   end
   else if H <360 then begin
     R := 255;
     G := 0;
     B := Round(255-(255/60)*(H-300));
   end;

   Sat := Abs((S-100)/100);
   R := Round(R-((R-128)*Sat));
   G := Round(G-((G-128)*Sat));
   B := Round(B-((B-128)*Sat));

   Lum := (L-50)/50;
   if Lum > 0 then begin
     R := Round(R+((255-R)*Lum));
     G := Round(G+((255-G)*Lum));
     B := Round(B+((255-B)*Lum));
   end
   else if Lum < 0 then begin
     R := Round(R+(R*Lum));
     G := Round(G+(G*Lum));
     B := Round(B+(B*Lum));
   end;
 end;
end;


function GetSubStr(Str : string; index : integer):string;
var
  substr : string;
  i,j: integer;
begin
   if index <0 then begin
    Result := ';
    exit;
   end;
   i := 0;
   substr := str;
   while i<=index do
   begin
      j := Pos(',',substr);
      if j = 0 then begin
        if i <>index then substr := ';
        break
      end else begin
         if i = index then substr := copy(substr,1,j-1)
         else delete(substr,1,j); //删除
         Inc(i);
      end;
   end;
   Result := substr;
end;


function mMove(i : integer):string;
begin
   SetLength(Result,sizeof(i));
   Move(i, Result[1], sizeof(i));
end;

function mMove(i : int64):string;
begin
   SetLength(Result,sizeof(i));
   Move(i, Result[1], sizeof(i));
end;

function mMove(i : boolean):string;
begin
   SetLength(Result,sizeof(i));
   Move(i, Result[1], sizeof(i));
end;
function mMove(i : Word):string;
begin
   SetLength(Result,sizeof(i));
   Move(i, Result[1], sizeof(i));
end;

function mMove(i : Byte):string;
begin
   SetLength(Result,sizeof(i));
   Move(i, Result[1], sizeof(i));
end;

function mMove(p : Pchar; Size: integer): string;
begin
   SetLength(Result,size);
   Move(p[0], Result[1], size);
end;
procedure mMove(var i : integer;var Source: string);
begin
  Move(Source[1],i,sizeof(i));
  delete(Source,1,sizeof(i));
end;

procedure mMove(var i : int64; var Source: string);
begin
  Move(Source[1],i,sizeof(i));
  delete(Source,1,sizeof(i));
end;

procedure mMove(var i : boolean; var Source: string);
begin
  Move(Source[1],i,sizeof(i));
  delete(Source,1,sizeof(i));
end;

procedure mMove(var i : Word; var Source: string);
begin
  Move(Source[1],i,sizeof(i));
  delete(Source,1,sizeof(i));
end;

procedure mMove(var i : Byte; var Source: string);
begin
  Move(Source[1],i,sizeof(i));
  delete(Source,1,sizeof(i));
end;

procedure StrToIntStr(var Data: string); //字串转整数
var
  i : integer;
begin
  for i := 1 to Length(Data) do
  Data[i] := Chr(Byte(Data[i])- 48);
end;

function GetAveCharSize(Canvas: TCanvas): TPoint;
var
  I: Integer;
  Buffer: array[0..51] of Char;
begin
  for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
  for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
  GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
  Result.X := Result.X div 52;
end;

var
    ModalResults: array[TMsgDlgBtn] of Integer = (
    mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll,
    mrYesToAll, 0);

function MaskForm(const imask : Byte): Byte;
var
  Form: TForm;
  cbSys: TCheckBox;
  cbFont: TCheckBox;
  cbFace: TCheckBox;
  Button: TButton;
begin
  Result := 0;
  Form := TForm.Create(Application);
  with Form do
    try
      Font.Name := '宋体';
      Font.Size := 9;
      Canvas.Font := Font;
      BorderStyle := bsDialog;
      Caption := '屏蔽设置';
      Position := poScreenCenter;
      Width := 257;
      Height := 145;
      cbSys := TcheckBox.Create(Form);
      with cbSys do
      begin
       parent := Form;
       Left := 24;
       Top := 24;
       Caption := '屏蔽系统信息';
       ParentFont := true;
       if Bool(imask and $01) then Checked := true;
      end;
      cbFont := TcheckBox.Create(Form);
      with cbFont do
      begin
       parent := Form;
        Left := 136;
        Top := 24;
       Caption := '屏蔽字体设置';
       ParentFont := true;
       if Bool(imask and $02) then Checked := true;
      end;
      cbFace:=  TCheckBox.Create(Form);
      with cbFace do begin
       parent := Form;
       Left := 24;
       Top := 56;
       Caption := '屏蔽聊天表情';
       ParentFont := true;
       if Bool(imask and $04) then Checked := true;
      end;
      Button:= TButton.Create(Form);
      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := '确定';
        ModalResult := mrOk;
        Default := True;
        Left := (parent.Width - Width) div 2;
        Top := parent.ClientHeight - Height - 10;
      end;
      if ShowModal = mrOk then
      begin
        if cbSys.Checked then Result := 1;
        if cbFont.Checked then Inc(Result,2);
        if cbFace.Checked then Inc(Result,4);
      end;
   finally
    Form.Free;
   end;
end;

function InputBoxEx(const ACaption, APrompt, ADefault: string): string;
var
  Form: TForm;
  Prompt: TLabel;
  Edit: TEdit;
  DialogUnits: TPoint;
  ButtonTop, ButtonWidth, ButtonHeight: Integer;
begin
  Result := ADefault;

  Form := TForm.Create(Application);
  with Form do
    try
      Font.Name := '宋体';
      Font.Size := 9;
      Canvas.Font := Font;
      DialogUnits := GetAveCharSize(Canvas);
      BorderStyle := bsDialog;
      Caption := ACaption;
      ClientWidth := MulDiv(180, DialogUnits.X, 4);
      Position := poScreenCenter;
      Prompt := TLabel.Create(Form);
      with Prompt do
      begin
        Parent := Form;
        Caption := APrompt;
        Left := MulDiv(8, DialogUnits.X, 4);
        Top := MulDiv(8, DialogUnits.Y, 8);
        Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4);
        WordWrap := True;
      end;
      Edit := TEdit.Create(Form);
      with Edit do
      begin
        Parent := Form;
        Left := Prompt.Left;
        Top := Prompt.Top + Prompt.Height + 5;
        Width := MulDiv(164, DialogUnits.X, 4);
        MaxLength := 255;
        Text := Result;
        SelectAll;
      end;
      ButtonTop := Edit.Top + Edit.Height + 15;
      ButtonWidth := MulDiv(50, DialogUnits.X, 4);
      ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := '确定';
        ModalResult := mrOk;
        Default := True;
        SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,
          ButtonHeight);
      end;
      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := '取消';
        ModalResult := mrCancel;
        Cancel := True;
        SetBounds(MulDiv(92, DialogUnits.X, 4), Edit.Top + Edit.Height + 15,
          ButtonWidth, ButtonHeight);
        Form.ClientHeight := Top + Height + 13;          
      end;
      if ShowModal = mrOk then
      begin
        Result := Edit.Text;
      end;
    finally
      Form.Free;
    end;
end;
//**********显示数字于一个框内start**********//

procedure DrawSegment(Canvas: TCanvas; dSegNum : Integer;const SegmentRect : TRect);
const
  cBorderGap = 1;  //边界宽度
  cSegmentThickness = 2; //每个线条宽度
  cHorzMargine = 1; //水平线条边界缩进
  cVertMargine = 1; //竖直线条边界缩进
var
   Ht,Lt,Rt,Tp,Bt,VertCentre, SegHalf : Integer;
   fPoints   : array [1..6] of TPoint;
begin
    Ht := SegmentRect.Bottom - SegmentRect.Top;
    Lt := SegmentRect.Left+cBorderGap;
    Rt := SegmentRect.Right-cBorderGap - 1 - (cSegmentThickness * 2); //move in a seg and a half
    Tp := SegmentRect.Top+cBorderGap;
    Bt := Ht-cBorderGap-1 +  SegmentRect.Top;

    VertCentre := ((Bt - Tp) div 2);
    SegHalf    := (cSegmentThickness div 2);

     case dSegNum of
          0 :
          begin
          fPoints[1].x := Rt + cSegmentThickness{SegHalf};
          fPoints[1].y := Bt - (VertCentre div 2);// - (cSegmentThickness * 2);

          fPoints[2].x := Rt + SegHalf + cSegmentThickness * 2;// - (SegHalf + cSegmentThickness);
          fPoints[2].y := Bt;

          Canvas.Ellipse(fPoints[1].x, fPoints[1].y, fPoints[2].x, fPoints[2].y);
          end;
          3 :
          begin
          fPoints[1].x := Lt + cHorzMargine;
          fPoints[1].y := Tp;

          fPoints[2].x := Rt - cHorzMargine;
          fPoints[2].y := Tp;

          fPoints[3].x := fPoints[2].x - cSegmentThickness;
          fPoints[3].y := fPoints[2].y + cSegmentThickness;

          fPoints[4].x := fPoints[1].x + cSegmentThickness;
          fPoints[4].y := fPoints[1].y + cSegmentThickness;

          Canvas.Polygon(Slice(fPoints,4));
          end;

          4 :
          begin
          fPoints[1].x := Lt ;
          fPoints[1].y := Tp+cVertMargine;

          fPoints[2].x := Lt;
          fPoints[2].y := Tp+VertCentre-cVertMargine;

          fPoints[3].x := fPoints[2].x + cSegmentThickness;
          fPoints[3].y := fPoints[2].y - cSegmentThickness;

          fPoints[4].x := fPoints[1].x + cSegmentThickness;
          fPoints[4].y := fPoints[1].y + cSegmentThickness;

          Canvas.Polygon(Slice(fPoints,4));
          end;

          5:
          begin
          fPoints[1].x := Lt ;
          fPoints[1].y := Tp+cVertMargine+VertCentre;

          fPoints[2].x := Lt;
          fPoints[2].y := Tp+VertCentre-cVertMargine+VertCentre;

          fPoints[3].x := fPoints[2].x + cSegmentThickness;
          fPoints[3].y := fPoints[2].y - cSegmentThickness;

          fPoints[4].x := fPoints[1].x + cSegmentThickness;
          fPoints[4].y := fPoints[1].y + cSegmentThickness;

          Canvas.Polygon(Slice(fPoints,4));
          end;

          6:
          begin
          fPoints[1].x := Lt + cHorzMargine;
          fPoints[1].y := Tp+VertCentre+VertCentre;

          fPoints[2].x := Rt - cHorzMargine;
          fPoints[2].y := fPoints[1].y;

          fPoints[3].x := fPoints[2].x - cSegmentThickness;
          fPoints[3].y := fPoints[2].y - cSegmentThickness;

          fPoints[4].x := fPoints[1].x + cSegmentThickness;
          fPoints[4].y := fPoints[1].y - cSegmentThickness;

          Canvas.Polygon(Slice(fPoints,4));
          end;

          2:
          begin

          fPoints[1].x := Rt;
          fPoints[1].y := Tp+cVertMargine;

          fPoints[2].x := fPoints[1].x;
          fPoints[2].y := Tp+VertCentre-cVertMargine;

          fPoints[3].x := fPoints[2].x - cSegmentThickness;
          fPoints[3].y := fPoints[2].y - cSegmentThickness;

          fPoints[4].x := fPoints[1].x - cSegmentThickness;
          fPoints[4].y := fPoints[1].y + cSegmentThickness;

          Canvas.Polygon(Slice(fPoints,4));
          end;

          7:
          begin
          fPoints[1].x := Rt;
          fPoints[1].y := Tp+cVertMargine+VertCentre;

          fPoints[2].x := fPoints[1].x;
          fPoints[2].y := Tp+VertCentre-cVertMargine+VertCentre;

          fPoints[3].x := fPoints[2].x - cSegmentThickness;
          fPoints[3].y := fPoints[2].y - cSegmentThickness;

          fPoints[4].x := fPoints[1].x - cSegmentThickness;
          fPoints[4].y := fPoints[1].y + cSegmentThickness;
          Canvas.Polygon(Slice(fPoints,4));
          end;

          1:
          begin
          fPoints[1].x := Lt+cHorzMargine;
          fPoints[1].y := Tp+VertCentre;

          fPoints[2].x := fPoints[1].x + SegHalf;
          fPoints[2].y := Tp+VertCentre - SegHalf  ; // 1 is Pen size

          fPoints[3].x := Rt-cHorzMargine-SegHalf;
          fPoints[3].y := fPoints[2].y;

          fPoints[4].x := Rt-cHorzMargine;
          fPoints[4].y := fPoints[1].y;

          fPoints[5].x := Rt-cHorzMargine-SegHalf;
          fPoints[5].y := Tp+VertCentre + SegHalf;

          fPoints[6].x := fPoints[2].x;
          fPoints[6].y := fPoints[5].y ;

          Canvas.Polygon(fPoints);
          end;
     end;

end;

function Padr(s : String;numPad : Integer) : String;
var
   i,l    : Integer;
begin
     Result := ';
      l := numPad-Length(s);
      for i := 1 to l do
          Result := Result+' ';
     Result := Result + s;
end;

procedure DrawSegments(Canvas: TCanvas; dSegment : TCharSegment;SegmentRect : TRect);
var
   i      : Byte;
begin
     for i := 0 to 7 do
         if (byte(i) in dSegment) then
          DrawSegment(Canvas,i,SegmentRect);
end;
{
    3
    --
  4| 1 |2
    --
  5|   |7
    --  * 0
    6
}

procedure MakeSegments(dChar : Char;var dSegment : TCharSegment);
begin
     dSegment := [];
     case dChar of
          '1':  dSegment := [2,7];
          '2':  dSegment := [3,2,1,5,6];
          '3':  dSegment := [3,2,1,7,6];
          '4':  dSegment := [4,1,2,7];
          '5':  dSegment := [3,4,1,7,6];
          '6':  dSegment := [3,4,5,6,7,1];
          '7':  dSegment := [3,2,7];
          '8':  dSegment := [3,4,5,6,7,2,1];
          '9':  dSegment := [3,4,1,2,7];
          '0':  dSegment := [3,4,5,6,7,2];
          '-':  dSegment := [1];
          '.':  dSegment := [0];
     end;
end;

procedure ShowDigiInRect(Canvas: TCanvas; mRect: TRect; str : string); //显示数字在一个框里
const
  cNumChars = 2;
var
   MySeg  : TCharSegment;
   xPos, i : Integer;
   MyRect : TRect;
   csize  : Integer;
   s  : String;
   clFront, clBack : TColor;
begin
   s := Padr(str,cNumChars);
   cSize := (mRect.Right - mRect.Left) div Length(s);
   xPos := 0;
    clFront := canvas.Pen.Color ;
    clBack := canvas.Brush.Color;
    canvas.Brush.Color := clLime; // 添充色
    canvas.Pen.Color := clLime; //前景色

   for i := 1 to Length(s) do
        begin
          MakeSegments(s[i],MySeg);
          MyRect.Top := mRect.Top;
          MyRect.Bottom := mRect.Bottom;
          MyRect.Left := mRect.Left + (xPos)*cSize;
          MyRect.Right:= MyRect.Left+cSize;
          DrawSegments(Canvas,MySeg,MyRect);
          Inc(xPos);
       end;
  Canvas.Pen.Color := clFront;
  Canvas.Brush.Color := clBack;
end;
//**********显示数字于一个框内start**********//

function GetColorA(chint : boolean; vcolor : Tcolor) : TColor ; //改变阴影的函数
var
  r,g,b,H,S,L : integer;
  fcolor : TColor;
begin
  fColor := ColorToRGB(vcolor);
  b := GetBValue(fColor);
  g := GetGValue(fColor);
  r := GetRValue(fColor);
  RGBtoHSL(r,g,b,h,s,l);
  if chint then l := l + 15 else l := l - 15;
  HSLtoRGB(h,s,l,r,g,b);
  ReSult := RGB(r,g,b);
end;

function GetColor(chint : boolean; vcolor : Tcolor) : TColor ; //改变阴影的函数
var
  r,g,b,H,S,L : integer;
  fcolor : TColor;
begin
  fColor := ColorToRGB(vcolor);
  b := GetBValue(fColor);
  g := GetGValue(fColor);
  r := GetRValue(fColor);
  RGBtoHSL(r,g,b,h,s,l);
  if chint then l := l + 35 else l := l - 35;
  HSLtoRGB(h,s,l,r,g,b);
  ReSult := RGB(r,g,b);
end;

{$IFNDEF K_CB5}
procedure DrawBlockFrameSmall(vleft, vtop, vright,
  vbuttom: integer; DrawColor : TColor;Canvas : TCanvas);
var
  vcolor : DWORD;
  mPen : TPen;
begin
  mPen := TPen.Create;
  try
    mPen.Assign(Canvas.Pen);
    with Canvas do begin
      Brush.Color := DrawColor;
      Pen.Width := cFrame;
      Pen.Style := psclear;
      Rectangle(vLeft,vtop,vright,vbuttom);  //画主色哉
      vcolor := DWord(DrawColor);
      Pen.Style := psSolid;
      Pen.Color := GetColor(true,vcolor);         //画亮线
      MoveTo(vRight - cFrame, vTop);
      LineTo(vLeft,vTop);
      LineTo(vLeft,vButtom-cFrame);
      Pen.Color :=GetColor(false,vcolor);          //画暗线
      MoveTo(vLeft,vButtom - cFrame);
      LineTo(vRight- cFrame ,vButtom-cFrame);
      LineTo(vRight-cFrame,vTop);

      Pen.Width := 1;
    end;
    Canvas.Pen.Assign(mPen);
  finally
    mPen.Free;
  end;
end;

procedure DrawBlockFrameSmall(mRect: TRect; DrawColor: TColor;Canvas : TCanvas);
var
  vleft,vtop,vright,vbottom : integer;
begin
  vleft := mRect.Left;
  vtop := mRect.Top;
  vright := mRect.Right;
  vbottom := mRect.Bottom;
  DrawBlockFrameSmall(vleft,vtop,vright,vbottom,Drawcolor,Canvas);
end;

procedure DrawBlockFrameOnner(vleft, vtop, vright,
  vbuttom: integer; DrawColor : TColor;Canvas : TCanvas);
var
  vcolor : DWORD;
  mPen : TPen;
begin
  mPen := TPen.Create;
  try
    mPen.Assign(Canvas.Pen);
    with Canvas do begin
      Brush.Color := DrawColor;
      Pen.Width := cFrame;
      Pen.Style := psclear;
      Rectangle(vLeft,vtop,vright,vbuttom);  //画主色哉
      vcolor := DWord(DrawColor);
      Pen.Style := psSolid;
      Pen.Color := GetColorA(true,vcolor);         //画亮线
      MoveTo(vRight - cFrame, vTop);
      LineTo(vLeft,vTop);
      LineTo(vLeft,vButtom-cFrame);
      Pen.Color :=GetColorA(false,vcolor);          //画暗线
      MoveTo(vLeft,vButtom - cFrame);
      LineTo(vRight- cFrame ,vButtom-cFrame);
      LineTo(vRight-cFrame,vTop);

      Pen.Width := 1;
    end;
    Canvas.Pen.Assign(mPen);
  finally
    mPen.Free;
  end;
end;

procedure DrawBlockFrameOnner(mRect: TRect; DrawColor: TColor;Canvas : TCanvas);
var
  vleft,vtop,vright,vbottom : integer;
begin
  vleft := mRect.Left;
  vtop := mRect.Top;
  vright := mRect.Right;
  vbottom := mRect.Bottom;
  DrawBlockFrameOnner(vleft,vtop,vright,vbottom,Drawcolor,Canvas);
end;

procedure DrawBlockFrameInner(mRect: TRect;
  DrawColor: TColor ;Canvas : TCanvas);
var
  vleft,vtop,vright,vbottom : integer;
begin
  vleft := mRect.Left;
  vtop := mRect.Top;
  vright := mRect.Right;
  vbottom := mRect.Bottom;
  DrawBlockFrameInner(vleft,vtop,vright,vbottom,Drawcolor,Canvas);
end;

procedure DrawBlockFrameInner(vleft, vtop, vright,
  vbuttom: integer; DrawColor: TColor;Canvas : TCanvas);
var
  vcolor : DWORD;
  mPen : TPen;
begin
  mPen := TPen.Create;
  try
    mPen.Assign(Canvas.Pen);
    with Canvas do begin
      Brush.Color := DrawColor;
      Pen.Width := cFrame;
      Pen.Style := psclear;
      Rectangle(vLeft,vtop,vright,vbuttom);  //画主色哉
      vcolor := DWord(DrawColor);
      Pen.Style := psSolid;
      Pen.Color := GetColor(false,vcolor);         //画暗线
      MoveTo(vRight - cFrame, vTop);
      LineTo(vLeft,vTop);
      LineTo(vLeft,vButtom-cFrame);
      Pen.Color :=GetColor(true,vcolor);          //画亮线
      MoveTo(vLeft,vButtom - cFrame);
      LineTo(vRight- cFrame ,vButtom-cFrame);
      LineTo(vRight-cFrame,vTop);

      Pen.Width := 1;
    end;
    Canvas.Pen.Assign(mPen);
  finally
    mPen.Free;
  end;
end;

procedure DrawBlockFrameSiGuo(vleft, vtop, vright,
  vbuttom: integer; Canvas : TCanvas);
var
  mPen : TPenReCall;
begin
  mPen := TPenReCall.Create(Canvas.Pen);
  try
    with Canvas do begin
      Pen.Width := cFrame;
      Pen.Color := $00323456;
      MoveTo(vLeft + 10, vTop +1);
      LineTo(vLeft+1,vTop+1);
      LineTo(vLeft+1,vTop + 10);
      MoveTo(vRight - 10,vButtom- 1);
      LineTo(vRight-1,vButtom- 1);
      LineTo(vRight-1,vButtom - 10);
    end;
  finally
    mPen.Free;
  end;
end;

procedure DrawBlockFrameSiGuo(mRect: TRect; Canvas : TCanvas);
var
  vleft,vtop,vright,vbottom : integer;
begin
  vleft := mRect.Left;
  vtop := mRect.Top;
  vright := mRect.Right;
  vbottom := mRect.Bottom;
  DrawBlockFrameSiGuo(vleft,vtop,vright,vbottom,Canvas);
end;

{$Endif}

var
  vBuffer: array[0..MAX_PATH] of Char;
//////////快速字符串//////////

const
  cDeltaSize = 1.5;

var
  GUpcaseTable : array[0..255] of char;
  GUpcaseLUT: Pointer;

//NOTE : FastCharPos and FastCharPosNoCase do not require you to pass the length
//       of the string, this was only done in FastPos and FastPosNoCase because
//       they are used by FastReplace many times over, thus saving a LENGTH()
//       operation each time.  I can't see you using these two routines for the
//       same purposes so I didn't do that this time !
function FastCharPos(const aSource : String; const C: Char; StartPos : Integer) : Integer;
var
  L          : Integer;
begin
  //If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!
  Assert(StartPos > 0);
  
  Result := 0;
  L := Length(aSource);
  if L = 0 then exit;
  if StartPos > L then exit;
  Dec(StartPos);
  asm
      PUSH EDI          //Preserve this register

      mov  EDI, aSource        //Point EDI at aSource
      add  EDI, StartPos
      mov  ECX, L          //Make a note of how many chars to search through
      sub  ECX, StartPos
      mov  AL,  C          //and which char we want
    @Loop:
      cmp  Al, [EDI]          //compare it against the SourceString
      jz   @Found
      inc  EDI
      dec  ECX
      jnz  @Loop
      jmp  @NotFound
    @Found:
      sub  EDI, aSource        //EDI has been incremented, so EDI-OrigAdress = Char pos !
      inc  EDI
      mov  Result,   EDI
    @NotFound:

      POP  EDI
  end;
end;

function FastCharPosNoCase(const aSource : String; C: Char; StartPos : Integer) : Integer;
var
  L          : Integer;
begin
  Result := 0;
  L := Length(aSource);
  if L = 0 then exit;
  if StartPos > L then exit;
  Dec(StartPos);
  if StartPos < 0 then StartPos := 0;

  asm
      PUSH EDI          //Preserve this register
      PUSH EBX
      mov  EDX, GUpcaseLUT

      mov  EDI, aSource        //Point EDI at aSource
      add  EDI, StartPos
      mov  ECX, L          //Make a note of how many chars to search through
      sub  ECX, StartPos

      xor  EBX, EBX
      mov  BL,  C
      mov  AL, [EDX+EBX]
    @Loop:
      mov  BL, [EDI]
      inc  EDI
      cmp  Al, [EDX+EBX]
      jz   @Found
      dec  ECX
      jnz  @Loop
      jmp  @NotFound
    @Found:
      sub  EDI, aSource        //EDI has been incremented, so EDI-OrigAdress = Char pos !
      mov  Result,   EDI
    @NotFound:

      POP  EBX
      POP  EDI
  end;
end;

function FastmemPos(const aSource, aFind; const aSourceLen, aFindLen : integer) : Pointer;
asm
          push ESI
          push EDI
          push EBX

          mov  ESI, aFind
          mov  EDI, aSource
          mov  ECX, aSourceLen

  //Quick exit code
          mov  Result, 0
  //SourceLen < FindLen
          cmp  ECX, aFindLen
          jl   @TheEnd
  //FindLen < 1
          cmp  aFindLen, 1
          jl   @TheEnd

  //Now DEC aSourceLen by aFindLen-1
          sub  ECX, aFindLen
          inc  ECX

  //Get the first char of aFindString, note how it is done outside
  //of the main loop, as it never changes !
          Mov  Al, [ESI]
          jmp  @Scasb
  @FindNext:
          inc  EDI  //Done only when returning from CompareStrings
          dec  ECX
          jz   @NotFound

  //Now the FindFirstCharacter loop !
  @ScaSB:
  //Get the value of the current character in aSourceString
  //This is equal to ah := EDI^, that is what the [] are around [EDI]
  //compare this character with aDestString[1]
          cmp [EDI], al
  //If they are equal we compare the strings

          jz   @CompareStrings
          inc  EDI
          dec  ECX
          jnz  @ScaSB
          jmp  @NotFound

  @CompareStrings:
  //Put the length of aFindLen in EBX
          mov  EBX, aFindLen

  @CompareNext:
  //We DEC EBX to point to the end of the string, ie, we dont
  //want to add the whole length as this would point past the end of string
          dec  EBX
          jz   @FullMatch

  //here is another optimization tip !
  //People at this point usually PUSH ESI etc and then POP ESI etc
  //at the end, instead I opted not to change ESI etc at all.
  //This saves lots of pushing and popping !

  //Get aFindString character + aFindStringLength (the last char)
          mov  Ah, [ESI+EBX]

  //Get aSourceString character (current position + aFindStringLength)
  //Compare them
          cmp  Ah, [EDI+EBX]
          Jnz  @FindNext

          Jmp  @CompareNext

    @FullMatch:
          //Move the address of the *current* character in EDI
          //note, we have not altered EDI since the first char was found
          mov  Result, EDI
          jmp  @TheEnd
    @NotFound:
          //The substring was not found
          mov  Result, 0

  @TheEnd:
          pop  EBX
          pop  EDI
          pop  ESI
end;

function FastmemPosNC(const aSource, aFind; const aSourceLen, aFindLen : integer) : Pointer;
asm
          push ESI
          push EDI
          push EBX

          mov  ESI, aFind
          mov  EDI, aSource
          mov  ECX, aSourceLen

  //Quick exit code
          mov  Result, 0
  //SourceLen < FindLen
          cmp  ECX, aFindLen
          jl   @TheEnd
  //FindLen < 1
          cmp  aFindLen, 1
          jl   @TheEnd

  //Now DEC aSourceLen by aFindLen-1
          sub  ECX, aFindLen
          inc  ECX

  //Get the first char of aFindString, note how it is done outside
  //of the main loop, as it never changes !
          mov  EDX, GUpcaseLUT
          xor  EBX, EBX
          jmp  @FindFirst
  @FindNext:
          inc  EDI  //Done only when returning from CompareStrings
          dec  ECX
          jz   @NotFound
  @FindFirst:
          mov  Bl, [ESI]
          mov  AL, [EDX+EBX]

  //Now the FindFirstCharacter loop !
  @ScaSB:
  //Get the value of the current character in aSourceString
  //This is equal to ah := EDI^, that is what the [] are around [EDI]
  //compare this character with aDestString[1]
          mov  Bl, [EDI]
          cmp  Al, [EDX+EBX]
  //If they are equal we compare the strings

          jz   @CompareStrings
          inc  EDI
          dec  ECX
          jnz  @ScaSB
          jmp  @NotFound

  @CompareStrings:
  //Save ECX
          push ECX
          mov  ECX, aFindLen

  @CompareNext:
          dec  ECX
          jz   @FullMatch

          mov  Bl, [ESI+ECX]
          mov  Al, [EDX+EBX]

          mov  Bl, [EDI+ECX]
          cmp  Al, [EDX+EBX]
          jz   @KeepChecking

          POP  ECX
          jmp  @FindNext

    @KeepChecking:
          Jmp  @CompareNext

    @FullMatch:
          pop  ECX
          mov  Result, EDI
          jmp  @TheEnd

    @NotFound:
          mov  Result, 0

  @TheEnd:
          pop  EBX
          pop  EDI
          pop  ESI
end;


//The first thing to note here is that I am passing the SourceLength and FindLength
//As neither Source or Find will alter at any point during FastReplace there is
//no need to call the LENGTH subroutine each time !
function FastPos(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
begin
  //If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!
  Assert(StartPos > 0);
  
  Result := Integer(FastmemPos(aSourceString[StartPos], aFindString[1],aSourceLen - (StartPos-1), aFindLen));
  if Result > 0 then
    Result := Result - Integer(@aSourceString[1]) +1;
end;

function FastPosNoCase(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
begin
  //If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!
  Assert(StartPos > 0);

  Result := Integer(FastmemPosNC(aSourceString[StartPos], aFindString[1],aSourceLen - (StartPos-1), aFindLen));
  if Result > 0 then
    Result := Result - Integer(@aSourceString[1]) +1;
end;

function FastPosBack(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
  SourceLen : Integer;
begin
  if aFindLen < 1 then begin
    Result := 0;
    exit;
  end;
  if aFindLen > aSourceLen then begin
    Result := 0;
    exit;
  end;

  if (StartPos = 0) or  (StartPos + aFindLen >= aSourceLen) then
    SourceLen := aSourceLen - (aFindLen-1)
  else
    SourceLen := StartPos;

  asm
          push ESI
          push EDI
          push EBX

          mov EDI, aSourceString
          add EDI, SourceLen
          Dec EDI

          mov ESI, aFindString
          mov ECX, SourceLen
          Mov  Al, [ESI]

    @ScaSB:
          cmp  Al, [EDI]
          jne  @NextChar

    @CompareStrings:
          mov  EBX, aFindLen
          dec  EBX
          jz   @FullMatch

    @CompareNext:
          mov  Ah, [ESI+EBX]
          cmp  Ah, [EDI+EBX]
          Jnz  @NextChar

    @Matches:
          Dec  EBX
          Jnz  @CompareNext

    @FullMatch:
          mov  EAX, EDI
          sub  EAX, aSourceString
          inc  EAX
          mov  Result, EAX
          jmp  @TheEnd
    @NextChar:
          dec  EDI
          dec  ECX
          jnz  @ScaSB

          mov  Result,0

    @TheEnd:
          pop  EBX
          pop  EDI
          pop  ESI
  end;
end;


function FastPosBackNoCase(const aSourceString, aFindString : String; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
  SourceLen : Integer;
begin
  if aFindLen < 1 then begin
    Result := 0;
    exit;
  end;
  if aFindLen > aSourceLen then begin
    Result := 0;
    exit;
  end;

  if (StartPos = 0) or  (StartPos + aFindLen >= aSourceLen) then
    SourceLen := aSourceLen - (aFindLen-1)
  else
    SourceLen := StartPos;

  asm
          push ESI
          push EDI
          push EBX

          mov  EDI, aSourceString
          add  EDI, SourceLen
          Dec  EDI

          mov  ESI, aFindString
          mov  ECX, SourceLen

          mov  EDX, GUpcaseLUT
          xor  EBX, EBX

          mov  Bl, [ESI]
          mov  Al, [EDX+EBX]

    @ScaSB:
          mov  Bl, [EDI]
          cmp  Al, [EDX+EBX]
          jne  @NextChar

    @CompareStrings:
          PUSH ECX
          mov  ECX, aFindLen
          dec  ECX
          jz   @FullMatch

    @CompareNext:
          mov  Bl, [ESI+ECX]
          mov  Ah, [EDX+EBX]
          mov  Bl, [EDI+ECX]
          cmp  Ah, [EDX+EBX]
          Jz   @Matches

    //Go back to findind the first char
          POP  ECX
          Jmp  @NextChar

    @Matches:
          Dec  ECX
          Jnz  @CompareNext

    @FullMatch:
          POP  ECX

          mov  EAX, EDI
          sub  EAX, aSourceString
          inc  EAX
          mov  Result, EAX
          jmp  @TheEnd
    @NextChar:
          dec  EDI
          dec  ECX
          jnz  @ScaSB

          mov  Result,0

    @TheEnd:
          pop  EBX
          pop  EDI
          pop  ESI
  end;
end;

//My move is not as fast as MOVE when source and destination are both
//DWord aligned, but certainly faster when they are not.
//As we are moving characters in a string, it is not very likely at all that
//both source and destination are DWord aligned, so moving bytes avoids the
//cycle penality of reading/writing DWords across physical boundaries
procedure FastCharMove(const Source; var Dest; Count : Integer);
asm
//Note:  When this function is called, delphi passes the parameters as follows
//ECX = Count
//EAX = Const Source
//EDX = Var Dest

        //If no bytes to copy, just quit altogether, no point pushing registers
        cmp   ECX,0
        Je    @JustQuit

        //Preserve the critical delphi registers
        push  ESI
        push  EDI

        //move Source into ESI  (generally the SOURCE register)
        //move Dest into EDI (generally the DEST register for string commands)
        //This may not actually be neccessary, as I am not using MOVsb etc
        //I may be able just to use EAX and EDX, there may be a penalty for
        //not using ESI, EDI but I doubt it, this is another thing worth trying !
        mov   ESI, EAX
        mov   EDI, EDX

        //The following loop is the same as repNZ MovSB, but oddly quicker !
    @Loop:
        //Get the source byte
        Mov   AL, [ESI]
        //Point to next byte
        Inc   ESI
        //Put it into the Dest
        mov   [EDI], AL
        //Point dest to next position
        Inc   EDI
        //Dec ECX to note how many we have left to copy
        Dec   ECX
        //If ECX <> 0 then loop
        Jnz   @Loop

        //Another optimization note.
        //Many people like to do this

        //Mov AL, [ESI]
        //Mov [EDI], Al
        //Inc ESI
        //Inc ESI

        //There is a hidden problem here, I wont go into too much detail, but
        //the pentium can continue processing instructions while it is still
        //working out the desult of INC ESI or INC EDI
        //(almost like a multithreaded CPU)
        //if, however, you go to use them while they are still being calculated
        //the processor will stop until they are calculated (a penalty)
        //Therefore I alter ESI and EDI as far in advance as possible of using them

        //Pop the critical Delphi registers that we have altered
        pop   EDI
        pop   ESI
    @JustQuit:
end;

//Point 1
//I pass CONST aSourceString rather than just aSourceString
//This is because I will just be passed a pointer to the data
//rather than a 10mb copy of the data itself, much quicker !
function FastReplace(const aSourceString : String; const aFindString, aReplaceString : String;
   CaseSensitive : Boolean = False) : String;
var
  PResult          : PChar;
  PReplace          : PChar;
  PSource          : PChar;
  PFind          : PChar;
  PPosition          : PChar;
  CurrentPos,
  BytesUsed,
  lResult,
  lReplace,
  lSource,
  lFind          : Integer;
  Find          : TFastPosProc;

  CopySize          : Integer;
begin
  LSource := Length(aSourceString);
  if LSource = 0 then begin
    Result := aSourceString;
    exit;
  end;
  PSource := @aSourceString[1];

  LFind := Length(aFindString);
  if LFind = 0 then exit;
  PFind := @aFindString[1];

  LReplace := Length(aReplaceString);

  //Here we may get an Integer Overflow, or OutOfMemory, if so, we use a Delta

  try
    if LReplace <= LFind then
      SetLength(Result,lSource)
    else
      SetLength(Result, (LSource *LReplace) div  LFind);
  except
    SetLength(Result,0);
  end;

  LResult := Length(Result);
  if LResult = 0 then begin
    LResult := Trunc((LSource + LReplace) * cDeltaSize);
    SetLength(Result, LResult);
  end;


  PResult := @Result[1];


  if CaseSensitive then
    Find := FastmemPos
  else
    Find := FastmemPosNC;


  if LReplace > 0 then begin
    BytesUsed := 0;
    PReplace := @aReplaceString[1];
    repeat
      PPosition := Find(PSource^,PFind^,lSource, lFind);
      if PPosition = nil then break;

      CopySize := PPosition - PSource;
      Inc(BytesUsed, CopySize + LReplace);

      if BytesUsed >= LResult then begin
        //We have run out of space
        CurrentPos := Integer(PResult) - Integer(@Result[1]) +1;
        LResult := Trunc(LResult * cDeltaSize);
        SetLength(Result,LResult);
        PResult := @Result[CurrentPos];
      end;

      FastCharMove(PSource^,PResult^,CopySize);
      Dec(lSource,CopySize + LFind);
      Inc(PSource,CopySize + LFind);
      Inc(PResult,CopySize);

      FastCharMove(PReplace^,PResult^,LReplace);
      Inc(PResult,LReplace);

    until lSource < lFind;
  end else begin
    repeat
      PPosition := Find(PSource^,PFind^,lSource, lFind);
      if PPosition = nil then break;

      CopySize := PPosition - PSource;
      FastCharMove(PSource^,PResult^,CopySize);
      Dec(lSource,CopySize + LFind);
      Inc(PSource,CopySize + LFind);
      Inc(PResult,CopySize);

    until lSource < lFind;
  end;

  FastCharMove(PSource^,PResult^,LSource);
  SetLength(Result, (PResult+LSource) - @Result[1]);
end;

function SmartPos(const SearchStr,SourceStr : String;
          const CaseSensitive : Boolean = TRUE;
          const StartPos : Integer = 1;
          const ForwardSearch : Boolean = TRUE) : Integer;
begin
  // NOTE:  When using StartPos, the returned value is absolute!
  if (CaseSensitive) then
    if (ForwardSearch) then
      Result:=
        FastPos(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
    else
      Result:=
        FastPosBack(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
  else
    if (ForwardSearch) then
      Result:=
        FastPosNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
    else
      Result:=
        FastPosBackNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
end;

var
  I: Integer;

const
  cKey1 = 52845;
  cKey2 = 22719;

function StripHTMLorNonHTML(S : String; WantHTML : Boolean) : String; forward;

//Encrypt a string
function Encrypt(const S: String; Key: Word): String;
var
I: byte;
begin
 SetLength(result,length(s));
 for I := 1 to Length(S) do
    begin
        Result[I] := char(byte(S[I]) xor (Key shr 8));
        Key := (byte(Result[I]) + Key) * cKey1 + cKey2;
    end;
end;

//Return only the HTML of a string
function ExtractHTML(S : String) : String;
begin
  Result := StripHTMLorNonHTML(S,True);
end;

function CopyStr(const aSourceString : String; aStart, aLength : Integer) : String;
var
  L: Integer;
begin
  L := Length(aSourceString);
  if L=0 then exit;

  if aStart + (aLength-1) > L then aLength := L - (aStart-1);

  if (aStart <1) then exit;

  SetLength(Result,aLength);
  FastCharMove(aSourceString[aStart], Result[1], aLength);
end;

//Take all HTML out of a string
function ExtractNonHTML(S : String) : String;
begin
  Result := StripHTMLorNonHTML(S,False);
end;

//Decrypt a string encoded with Encrypt
function Decrypt(const S: String; Key: Word): String;
var
I: byte;
begin
 SetLength(result,length(s));
 for I := 1 to Length(S) do
    begin
        Result[I] := char(byte(S[I]) xor (Key shr 8));
        Key := (byte(S[I]) + Key) * cKey1 + cKey2;
    end;
end;

//GetValue("age","name=pete password=pete age=27") would return 27
function GetValue(ValueName, Text : String) : String;
var
  S     : String;
  L,
  X,
  P     : Integer;
  FoundEquals,
  WordStarted,
  InQuote : Boolean;
begin
  Result := ';
  S := UpperCase(Text);
  P := Pos(UpperCase(ValueName),S);
  if P = 0 then exit;

  Delete(Text,1,P-1);

  L := Length(S);
  WordStarted := False;
  FoundEquals := False;
  InQuote := False;

  for X := 1 to L do
    if Text[X] = '=' then begin
      FoundEquals := True;
      P := X;
      Break;
    end;

  if not FoundEquals then exit;

  for X := P +1 to L do
    if Text[X] <> ' ' then begin
      WordStarted := True;
      P := X;
      Break;
    end;

  if not WordStarted then exit;

  if Text[X] in ['"', ''] then begin
    InQuote := True;
    Inc(P);
  end;

  for X:= P to L do begin
    if InQuote then begin
      if Text[X] in ['"', ''] then
        Break
      else
        Result := Result + Text[X];
    end else begin
      if UpCase(Text[X]) in ['A'..'Z','0'..'9','\','/','.','-','_',':'] then
        Result := Result + Text[X]
      else
        Break;
    end;
  end;
end;

//Convert a text-HEX value (FF0088 for example) to an integer
function  HexToInt(aHex : String) : int64;
var
  Multiplier      : Int64;
  Position        : Byte;
  Value          : Integer;
begin
  Result := 0;
  Multiplier := 1;
  Position := Length(aHex);
  while Position >0 do begin
    Value := FastCharPosNoCase(cHexChars, aHex[Position], 1)-1;
    if Value = -1 then
      raise Exception.Create('Invalid hex character ' + aHex[Position]);

    Result := Result + (Value * Multiplier);
    Multiplier := Multiplier * 16;
    Dec(Position);
  end;
end;

//Get the left X amount of chars
function LeftStr(const aSourceString : String; Size : Integer) : String;
begin
  if Size > Length(aSourceString) then
    Result := aSourceString
  else begin
    SetLength(Result, Size);
    Move(aSourceString[1],Result[1],Size);
  end;
end;

//Do strings match with wildcards, eg
//StringMatches('The cat sat on the mat', 'The * sat * the *') = True
function StringMatches(Value, Pattern : String) : Boolean;
var
  NextPos,
  Star1,
  Star2       : Integer;
  NextPattern   : String;
begin
  Star1 := FastCharPos(Pattern,'*',1);
  if Star1 = 0 then
    Result := (Value = Pattern)
  else begin
    Result := (Copy(Value,1,Star1-1) = Copy(Pattern,1,Star1-1));
    if Result then begin
      if Star1 > 1 then Value := Copy(Value,Star1,Length(Value));
      Pattern := Copy(Pattern,Star1+1,Length(Pattern));

      NextPattern := Pattern;
      Star2 := FastCharPos(NextPattern, '*',1);
      if Star2 > 0 then NextPattern := Copy(NextPattern,1,Star2-1);

      NextPos := pos(NextPattern,Value);
      if (NextPos = 0) and not (NextPattern = ') then
        Result := False
      else begin
        Value := Copy(Value,NextPos,Length(Value));
        if Pattern = ' then
          Result := True
        else
          Result := Result and StringMatches(Value,Pattern);
      end;
    end;
  end;
end;

//Missing text will tell you what text is missing, eg
//MissingText('the ? sat on the mat','the cat sat on the mat','?') = 'cat'
function MissingText(Pattern, Source : String; SearchText : String = '?') : String;
var
  Position          : Longint;
  BeforeText,
  AfterText          : String;
  BeforePos,
  AfterPos          : Integer;
  lSearchText,
  lBeforeText,
  lAfterText,
  lSource          : Longint;
begin
  Result := ';
  Position := Pos(SearchText,Pattern);
  if Position = 0 then exit;

  lSearchText := Length(SearchText);
  lSource := Length(Source);
  BeforeText := Copy(Pattern,1,Position-1);
  AfterText := Copy(Pattern,Position+lSearchText,lSource);

  lBeforeText := Length(BeforeText);
  lAfterText := Length(AfterText);

  AfterPos := lBeforeText;
  repeat
    AfterPos := FastPosNoCase(Source,AfterText,lSource,lAfterText,AfterPos+lSearchText);
    if AfterPos > 0 then begin
      BeforePos := FastPosBackNoCase(Source,BeforeText,AfterPos-1,lBeforeText,AfterPos - (lBeforeText-1));
      if (BeforePos > 0) then begin
        Result := Copy(Source,BeforePos + lBeforeText, AfterPos - (BeforePos + lBeforeText));
        Break;
      end;
    end;
  until AfterPos = 0;
end;

//Generates a random filename but preserves the original path + extension
function RandomFilename(aFilename : String) : String;
var
  Path,
  Filename,
  Ext          : String;
begin
  Result := aFilename;
  Path := ExtractFilepath(aFilename);
  Ext := ExtractFileExt(aFilename);
  Filename := ExtractFilename(aFilename);
  if Length(Ext) > 0 then
    Filename := Copy(Filename,1,Length(Filename)-Length(Ext));
  repeat
    Result := Path + RandomStr(32) + Ext;
  until not FileExists(Result);
end;

//Makes a string of aLength filled with random characters
function RandomStr(aLength : Longint) : String;
var
  X          : Longint;
begin
  if aLength <= 0 then exit;
  SetLength(Result, aLength);
  for X:=1 to aLength do
    Result[X] := Chr(Random(26) + 65);
end;

function ReverseStr(const aSourceString : String) : String;
var
  L          : Integer;
  S,
  D          : Pointer;
begin
  L := Length(aSourceString);
  SetLength(Result,L);
  if L = 0 then exit;

  S := @aSourceString[1];
  D := @Result[L];

  asm
    push ESI
    push EDI

    mov  ECX, L
    mov  ESI, S
    mov  EDI, D

  @Loop:
    mov  Al, [ESI]
    inc  ESI
    mov  [EDI], Al
    dec  EDI
    dec  ECX
    jnz  @Loop

    pop  EDI
    pop  ESI
  end;
end;

//Returns X amount of chars from the right of a string
function RightStr(const aSourceString : String; Size : Integer) : String;
begin
  if Size > Length(aSourceString) then
    Result := aSourceString
  else begin
    SetLength(Result, Size);
    FastCharMove(aSourceString[Length(aSourceString)-(Size-1)],Result[1],Size);
  end;
end;

//Converts a typical HTML RRGGBB color to a TColor
function RGBToColor(aRGB : String) : TColor;
begin
  if Length(aRGB) < 6 then raise EConvertError.Create('Not a valid RGB value');
  if aRGB[1] = '#' then aRGB := Copy(aRGB,2,Length(aRGB));
  if Length(aRGB) <> 6 then raise EConvertError.Create('Not a valid RGB value');

  Result := HexToInt(aRGB);
  asm
    mov   EAX, Result
    BSwap EAX
    shr   EAX, 8
    mov   Result, EAX
  end;
end;

//Splits a delimited text line into TStrings (does not account for stuff in quotes but it should)
procedure Split(aValue : String; aDelimiter : Char; Result : TStrings);
var
  X : Integer;
  S : String;
begin
  if Result = nil then Result := TStringList.Create;
  Result.Clear;
  S := ';
  for X:=1 to Length(aValue) do begin
    if aValue[X] <> aDelimiter then
      S:=S + aValue[X]
    else begin
      Result.Add(S);
      S := ';
    end;
  end;
  if S <> ' then Result.Add(S);
end;

//counts how many times a substring exists within a string
//StringCount('XXXXX','XX') would return 2
function StringCount(const aSourceString, aFindString : String; Const CaseSensitive : Boolean = TRUE) : Integer;
var
  Find,
  Source,
  NextPos          : PChar;
  LSource,
  LFind          : Integer;
  Next          : TFastPosProc;
begin
  Result := 0;
  LSource := Length(aSourceString);
  if LSource = 0 then exit;

  LFind := Length(aFindString);
  if LFind = 0 then exit;

  if CaseSensitive then
    Next := FastmemPos
  else
    Next := FastmemPosNC;

  Source := @aSourceString[1];
  Find := @aFindString[1];

  repeat
    NextPos := Next(Source^,Find^,LSource,LFind);
    if NextPos <> nil then begin
      Dec(LSource, (NextPos - Source) + LFind);
      Inc(Result);
      Source := NextPos + LFind;
    end;
  until NextPos = nil;
end;

//Used by ExtractHTML and ExtractNonHTML
function StripHTMLorNonHTML(S : String; WantHTML : Boolean) : String;
var
  X,
  TagCnt    : Integer;
begin
  S := StringReplace(S,' ',' ',[rfReplaceAll, rfIgnoreCase]);
  S := StringReplace(S,'&','&', [rfReplaceAll, rfIgnoreCase]);
  S := StringReplace(S,'<','<', [rfReplaceAll, rfIgnoreCase]);
  S := StringReplace(S,'>','>', [rfReplaceAll, rfIgnoreCase]);
  s := StringReplace(S,'"','"', [rfReplaceAll, rfIgnoreCase]);
  TagCnt := 0;
  Result := ';
  For X:=1 to Length(S) do begin
    case S[X] of
      '<' : Inc(TagCnt);
      '>' : Dec(TagCnt);
    else
      case WantHTML of
        False :
          if TagCnt <= 0 then begin
          Result := Result + S[X];
          TagCnt := 0;
          end;
        True :
          if TagCnt >= 1 then begin
          Result := Result + S[X];
          end else
          if TagCnt < 0 then TagCnt := 0;
      end;
    end;
  end;
end;

//Generates a UniqueFilename, makes sure the file does not exist before returning a result
function UniqueFilename(aFilename : String) : String;
var
  Path,
  Filename,
  Ext          : String;
  Index          : Integer;
begin
  Result := aFilename;
  if FileExists(aFilename) then begin
    Path := ExtractFilepath(aFilename);
    Ext := ExtractFileExt(aFilename);
    Filename := ExtractFilename(aFilename);
    if Length(Ext) > 0 then
      Filename := Copy(Filename,1,Length(Filename)-Length(Ext));
    Index := 2;
    repeat
      Result := Path + Filename + IntToStr(Index) + Ext;
      Inc(Index);
    until not FileExists(Result);
  end;
end;

//Decodes all that %3c stuff you get in a URL
function  URLToText(aValue : String) : String;
var
  X     : Integer;
begin
  Result := ';
  X := 1;
  while X <= Length(aValue) do begin
    if aValue[X] <> '%' then
      Result := Result + aValue[X]
    else begin
      Result := Result + Chr( HexToInt( Copy(aValue,X+1,2) ) );
      Inc(X,2);
    end;
    Inc(X);
  end;
end;

//Returns the whole word at a position
function  WordAt(Text : String; Position : Integer) : String;
var
  L,
  X : Integer;
begin
  Result := ';
  L := Length(Text);

  for X:=Position to L do begin
    if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then
      Result := Result + Text[X]
    else
      Break;
  end;

  for X:=Position-1 downto 1 do begin
    if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then
      Result := Text[X] + Result
    else
      Break;
  end;
end;

//////////快速字符串//////////
//////////新的字符串涵 数收集//////////

function slash(value:string):string;
begin
if (value[length(value)]<>'\') then result:=value+'\' else result:=value;
end;


function capfirst(value:string):string;
var
i:integer;
s:string;
begin
s:=uppercase(value[1]);
for i:=2 to length(value) do
    if (ord(value[i-1])<33) then s:=s+uppercase(value[i]) else s:=s+lowercase(value[i]);
result:=s;
end;

function striptags(value:string):string;
var
i:integer;
s:string;
begin
i:=1;
s:=';
while i<=length(value) do
      begin
      if value[i]='<' then repeat inc(i) until (value[i]='>') else s:=s+value[i];
      inc(i);
      end;
result:=s;
end;

function replace(str,s1,s2:string;casesensitive:boolean):string;
var
i:integer;
s,t:string;
begin
s:=';
t:=str;
       repeat
       if casesensitive then i:=pos(s1,t) else i:=pos(lowercase(s1),lowercase(t));
       if i>0 then
          begin
          s:=s+Copy(t,1,i-1)+s2;
          t:=Copy(t,i+Length(s1),MaxInt);
          end
       else s:=s+t;
       until i<=0;
result:=s;
end;

function CopyFromChar(s:string;c:char;l:integer):string;
var i:integer;
begin
i:=pos(c,s);
result:=copy(s,i,l);
end;

function getwinsysdir:string;
var p:pchar;
    z:integer;
begin
z:=255;
getmem(p,z);
getsystemdirectory(p,z);
result:=slash(string(p));
freemem(p,z);
end;

function getwindir:string;
var p:pchar;
    z:integer;
begin
z:=255;
getmem(p,z);
getwindowsdirectory(p,z);
result:=slash(string(p));
freemem(p,z);
end;

function getinstalldir:string;
begin
result:=slash(extractfiledir(paramstr(0)));
end;


function getregvalue(root:integer;key,value:string):string;
var
rg:Tregistry;
begin
rg:=Tregistry.create;
  try
  rg.rootkey:=root;
  if rg.OpenKey(key,false) then result:=rg.readString(value) else result:=';
  finally
  rg.free;
  end;
end;

function getfiledate(filename:string):Tdatetime;
begin
if fileexists(filename) then
   result:=filedatetodatetime(fileage(filename)) else result:=maxint;
end;


function strtofloatdef(const s:string;def:Extended):Extended;
begin
     try
     result:=strtofloat(s);
     except
     result:=def;
     end;
end;

function volsphere(radius:single):extended;
begin
result:=((4/3)*pi*radius*radius*radius);
end;

function areasphere(radius:single):extended;
begin
result:=(4*pi*radius*radius);
end;

function volcylinder(radius,height:single):extended;
begin
result:=(pi*radius*radius*height);
end;

function areacylinder(radius,height:single):extended;
begin
result:=(2*pi*radius*height);
end;

function MinExt(const A:array of Extended):Extended;
var
i:integer;
begin
Result:=A[Low(A)];
for i:=Low(A)+1 to High(A) do if A[i]<Result then Result:=A[I];
end;

function MaxExt(const A:array of Extended):Extended;
var
i:integer;
begin
Result:=A[Low(A)];
for i:=Low(A)+1 to High(A) do if A[i]>Result then Result:=A[I];
end;

function MinInteger(const A:array of Integer):Integer;
var
i:integer;
begin
Result:=A[Low(A)];
for i:=Low(A)+1 to High(A) do if A[i]<Result then Result:=A[I];
end;

function MaxInteger(const A:array of integer):Integer;
var
i:integer;
begin
Result:=A[Low(A)];
for i:=Low(A)+1 to High(A) do if A[i]>Result then Result:=A[I];
end;

function InverseSum(const a:array of single):single;
var i:integer;
begin
result:=0;
for i:=low(a) to high(a) do result:=result+(1/a[i]);
result:=(1/result);
end;

function MarkUp(profit:single):single;
begin
result:=(100-(10000/(100+profit)));
end;

function SellingPrice(net:double;markup:single):double;
begin
result:=net+(net*markup/100);
end;

function NetPrice(gross:double;taxrate:single):double;
begin
result:=gross-(gross*(taxrate)/(100+taxrate));
end;

//////////新的字符串涵 数收集//////////
//////////得到系统路径//////////
Function GetApplicationExeName: string;
begin
 Result := ParamStr(0);
end;

Function GetApplicationShortExeName: string;
begin
 Result :=ExtractFileName(ParamStr(0));
end;

Function GetWindowsDir: string;  //c:\winnt
var
 vBuffer: array [0..MAX_PATH] of Char;
begin
 GetWindowsDirectory(vBuffer,MAX_PATH);
 Result :=vBuffer;
end;

Function GetSystemDir: string;  //c:\winnt\system32
var
 vBuffer: array [0..MAX_PATH] of Char;
begin
 GetSysTemDirectory(vBuffer,MAX_PATH);
 Result :=vBuffer;
end;

Function GetTempDir: string;  //应用程序的路径 如D:/winnt/temp
var
 vBuffer: array [0..MAX_PATH] of Char;
begin
 GetTempPath(MAX_PATH,vBuffer);
 Result :=vBuffer;
end;

Function GetApplicationPath:String; //应用程序的路径 如D:/feng/
begin
 Result:=ExtractFilePath(GetApplicationExeName);
end;

Function GetApplicationDir:String; //应用程序的路径 如D:/feng
begin
 Result:=ExtractFileDir(GetApplicationExeName);
end;

Function GetCurrentDir: string;  //应用程序的路径 如D:/feng
var
 vBuffer: array [0..MAX_PATH] of Char;
begin
 GetCurrentDirectory(MAX_PATH,vBuffer);
 Result :=vBuffer;
end;

//程序组目录
function GetProgramsDir: string;
begin
 Result:=GetSystemFolderDir(CSIDL_PROGRAMS);
end;

//我的文档       //如C:\My Documents
function GetMy_DocumentsDir: string;
begin
 Result:=GetSystemFolderDir(CSIDL_PERSONAL);
end;

function GetFavoritesDir: string;
begin
 Result:=GetSystemFolderDir(CSIDL_FAVORITES);
end;

function GetSystemFolderDir(mFolder: Integer): string;
{ 返回获取系统文件或系统目录}
{
 CSIDL_BITBUCKET 回收站
 CSIDL_DESKTOP          = $0000; 桌面
 CSIDL_INTERNET          = $0001;
 CSIDL_PROGRAMS          = $0002;  程序组 D:\Documents and Settings\Administrator\「开始」菜单\程序
 CSIDL_CONTROLS          = $0003;  控制面板
 CSIDL_PRINTERS          = $0004;  打印机
 CSIDL_PERSONAL          = $0005;  我的文档
 CSIDL_FAVORITES          = $0006;  收藏夹
 CSIDL_STARTUP          = $0007; 启动
 CSIDL_RECENT          = $0008;  最近文档
 CSIDL_SENDTO          = $0009;  发送到
 CSIDL_BITBUCKET          = $000a; 回收站
 CSIDL_STARTMENU          = $000b; 开始菜单
 CSIDL_DESKTOPDIRECTORY          = $0010; 桌面目录
 CSIDL_DRIVES          = $0011; 我的电脑
 CSIDL_NETWORK          = $0012;  网上邻居
 CSIDL_NETHOOD          = $0013;  网上邻居目录
 CSIDL_FONTS          = $0014;  字体
 CSIDL_TEMPLATES          = $0015; //模版
 CSIDL_COMMON_STARTMENU          = $0016;  //公用的开始菜单
 CSIDL_COMMON_PROGRAMS          = $0017;
 CSIDL_COMMON_STARTUP          = $0018;
 CSIDL_COMMON_DESKTOPDIRECTORY       = $0019;
 CSIDL_APPDATA          = $001a; //D:\Documents and Settings\Administrator\Application Data
 CSIDL_PRINTHOOD          = $001b; //D:\Documents and Settings\Administrator\PrintHood
 CSIDL_ALTSTARTUP          = $001d;         // DBCS
 CSIDL_COMMON_ALTSTARTUP         = $001e;         // DBCS
 CSIDL_COMMON_FAVORITES          = $001f;
 CSIDL_INTERNET_CACHE          = $0020;  D:\Documents and Settings\Administrator\Local Settings\Temporary Internet Files
 CSIDL_COOKIES          = $0021;   Cook文件夹
 CSIDL_HISTORY          = $0022;   历史文件夹
 CSIDL_COMMON_APPDATA          = $0023;
          = $0024;   D:\WINNT
          = $0025;   D:\WINNT\system32
          = $0026    D:\Program Files
          = $0027    D:\Documents and Settings\Administrator\My Documents\My Pictures
          = $0028    D:\Documents and Settings\Administrator
          = $0029    D:\WINNT\system32
}
var
 vItemIDList: PItemIDList;
 vBuffer: array[0..MAX_PATH] of Char;
begin
 SHGetSpecialFolderLocation(0, mFolder, vItemIDList);
 SHGetPathFromIDList(vItemIDList, vBuffer); //转换成文件系统的路径
 Result := vBuffer;
end;
//////////得到系统路径//////////
initialization
  GetModuleFileName(HInstance, vBuffer, MAX_PATH); //读取模块所在文件
  GetFileVersionInfomation(vBuffer, vModuleVersionInfomation); //读取模块版本信息
//////////快速字符串//////////
  for I:=0 to 255 do GUpcaseTable[I] := Chr(I);
  CharUpperBuff(@GUpcaseTable[1], 256);
  GUpcaseLUT := @GUpcaseTable[0];
//////////快速字符串//////////
finalization

end.
Google
 
本站原创作品,未经作者许可,严禁任何方式转载;转载作品,如果侵犯了您的权益,请联系我们
龙脉加密锁 15元起 Grid++Report 报表 申请支付@网
 相关文章
个人收集及编写的一个通用函数集
Longmaster 2005/11/8 下+0/浏+26892 评+10
DELPHI常用函数集及简要范例
boy 2003/8/31 下+9898/浏+53892 评+19
相关评论
共有评论10条 当前显示最后6条评论
lbren 2005/12/12 20:15:47
高手
cq9888 2005/12/16 15:15:01
谢谢!
tarmee 2006/1/19 15:45:00
有没有Pas文件可以下载?
页面里提供的代码编译有错误,很多''都被替换成了',根本不能用
要手工一个个改回来也太麻烦了。
librancj 2006/3/1 20:12:26
你可以自己随便写个小程序把“”全部自动替换回来哦
或者用UE ~DreamWeaver也行
aiding_001 2006/9/8 13:47:44
Head.inc里是什么内容呀? 没仔细看,觉得好像没什么用。
graham 2007/7/17 10:04:06
辛苦了!
我要发表评论 查看全部评论
 
  DELPHI盒子版权所有 1999-2023 V4.01 粤ICP备10103342号-1 更新RSS列表