hutil32.pas

乐都SQL版传奇全套代码,绝对可编译

unit HUtil32;

//============================================
// Latest Update date : 1998 1
// Add/Update Function and procedure :
// 		CaptureString
//       Str_PCopy          	(4/29)
//			Str_PCopyEx			 	(5/2)
//			memset					(6/3)
//       SpliteBitmap         (9/3)
//       ArrestString         (10/27)  {name changed}
//       IsStringNumber       (98'1/1)
//			GetDirList				(98'12/9)
//       GetFileDate          (98'12/9)
//       CatchString          (99'2/4)
//       DivString            (99'2/4)
//       DivTailString        (99'2/4)
//       SPos                 (99'2/9)
//============================================


interface

uses
  Classes, SysUtils, StrUtils, WinTypes, WinProcs, Graphics, Messages, Dialogs;

type
  Str4096 = array[0..4096] of Char;
  Str256 = array[0..256] of Char;
  TyNameTable = record
    Name: string;
    varl: LongInt;
  end;

  TLRect = record
    Left, Top, Right, Bottom: LongInt;
  end;

const
  MAXDEFCOLOR                           = 16;
  ColorNames                              : array[1..MAXDEFCOLOR] of TyNameTable =
    (
    (Name: 'BLACK'; varl: clBlack),
    (Name: 'BROWN'; varl: clMaroon),
    (Name: 'MARGENTA'; varl: clFuchsia),
    (Name: 'GREEN'; varl: clGreen),
    (Name: 'LTGREEN'; varl: clOlive),
    (Name: 'BLUE'; varl: clNavy),
    (Name: 'LTBLUE'; varl: clBlue),
    (Name: 'PURPLE'; varl: clPurple),
    (Name: 'CYAN'; varl: clTeal),
    (Name: 'LTCYAN'; varl: clAqua),
    (Name: 'GRAY'; varl: clGray),
    (Name: 'LTGRAY'; varl: clSilver),
    (Name: 'YELLOW'; varl: clYellow),
    (Name: 'LIME'; varl: clLime),
    (Name: 'WHITE'; varl: clWhite),
    (Name: 'RED'; varl: clRed)
    );

  MAXLISTMARKER                         = 3;
  LiMarkerNames                           : array[1..MAXLISTMARKER] of TyNameTable  =
    (
    (Name: 'DISC'; varl: 0),
    (Name: 'CIRCLE'; varl: 1),
    (Name: 'SQUARE'; varl: 2)
    );

  MAXPREDEFINE                          = 3;
  PreDefineNames                          : array[1..MAXPREDEFINE] of TyNameTable  =
    (
    (Name: 'LEFT'; varl: 0),
    (Name: 'RIGHT'; varl: 1),
    (Name: 'CENTER'; varl: 2)
    );




function CountGarbage(paper: TCanvas; Src: PChar; TargWidth: LongInt): Integer;
{garbage}
{[ArrestString]
    Result = Remain string,
    RsltStr = captured string
}
function ArrestString(Source, SearchAfter, ArrestBefore: string;
  const DropTags: array of string; var RsltStr: string): string;
{*}
function ArrestStringEx(Source, SearchAfter, ArrestBefore: string; var
  ArrestStr: string): string;
function CaptureString(Source: string; var rdstr: string): string;
procedure ClearWindow(aCanvas: TCanvas; aLeft, aTop, aRight, aBottom: LongInt;
  aColor: TColor);
function CombineDirFile(SrcDir, TargName: string): string;
{*}
function CompareLStr(Src, targ: string; compn: Integer): Boolean;
function CompareBackLStr(Src, targ: string; compn: Integer): Boolean;
function CompareBuffer(p1, p2: Pbyte; Len: Integer): Boolean;
function CreateMask(Src: PChar; TargPos: Integer): string;
procedure DrawTileImage(Canv: TCanvas; Rect: TRect; TileImage: TBitmap);
procedure DrawingGhost(Rc: TRect);
function ExtractFileNameOnly(const fname: string): string;
function FloatToString(F: real): string;
function FloatToStrFixFmt(fVal: Double; prec, digit: Integer): string;
function FileSize(const fname: string): LongInt;
{*}
function GetSpaceCount(str: string): LongInt;
function RemoveSpace(str: string): string;
function GetFirstWord(str: string; var sWord: string; var FrontSpace: LongInt):
  string;
function GetDefColorByName(str: string): TColor;
function GetULMarkerType(str: string): LongInt;
{*}
function GetValidStr3(str: string; var Dest: string; const Divider: array of
  Char): string;
function GetValidStr4(str: string; var Dest: string; const Divider: array of
  Char): string;
function GetValidStrVal(str: string; var Dest: string; const Divider: array of
  Char): string;
function GetValidStrCap(str: string; var Dest: string; const Divider: array of
  Char): string;
function GetStr(Str:string;const Divider:array of Char):String;
function GetStrToCoords(str: string): TRect;
function GetDefines(str: string): LongInt;
function GetValueFromMask(Src: PChar; Mask: string): string;
procedure GetDirList(path: string; fllist: TStringList);
function GetFileDate(FileName: string): Integer; //DOS format file date..
function HexToIntEx(shap_str: string): LongInt;
function HexToInt(str: string): LongInt;
function IntToStrFill(num, Len: Integer; fill: Char): string;
function IsInB(Src: string; Pos: Integer; targ: string): Boolean;
function IsInRect(x, y: Integer; Rect: TRect): Boolean;
function IsEnglish(ch: Char): Boolean;
function IsEngNumeric(ch: Char): Boolean;
function IsFloatNumeric(str: string): Boolean;
function IsUniformStr(Src: string; ch: Char): Boolean;
function IsStringNumber(str: string): Boolean;
function KillFirstSpace(var str: string): LongInt;
procedure KillGabageSpace(var str: string);
function LRect(l, t, r, b: LongInt): TLRect;
procedure MemPCopy(Dest: PChar; Src: string);
procedure MemCpy(Dest, Src: PChar; Count: LongInt);         {PChar type}
procedure memcpy2(TargAddr, SrcAddr: LongInt; Count: Integer); {Longint type}
procedure memset(Buffer: PChar; FillChar: Char; Count: Integer);
procedure PCharSet(P: PChar; n: Integer; ch: Char);
function ReplaceChar(Src: string; srcchr, repchr: Char): string;
function Str_ToDate(str: string): TDateTime;
function Str_ToTime(str: string): TDateTime;
function Str_ToDateTime(str: string): TDateTime;
function Str_ToInt(str: string; Def: LongInt): LongInt;
function Str_ToFloat(str: string): real;
function SkipStr(Src: string; const Skips: array of Char): string;
procedure ShlStr(Source: PChar; Count: Integer);
procedure ShrStr(Source: PChar; Count: Integer);
procedure Str256PCopy(Dest: PChar; const Src: string);
function _StrPas(Dest: PChar): string;
function Str_PCopy(Dest: PChar; Src: string): Integer;
function Str_PCopyEx(Dest: PChar; const Src: string; buflen: LongInt): Integer;
procedure SpliteBitmap(DC: hdc; x, y: Integer; bitmap: TBitmap; transcolor:
  TColor);
procedure TiledImage(Canv: TCanvas; Rect: TLRect; TileImage: TBitmap);
function Trim_R(const str: string): string;
function IsEqualFont(SrcFont, TarFont: TFont): Boolean;
function CutHalfCode(str: string): string;
function ConvertToShortName(Canvas: TCanvas; Source: string; WantWidth:
  Integer): string;
{*}
function CatchString(Source: string; cap: Char; var catched: string): string;
function DivString(Source: string; cap: Char; var sel: string): string;
function DivTailString(Source: string; cap: Char; var sel: string): string;
function SPos(substr, str: string): Integer;
function NumCopy(str: string): Integer;
function GetMonDay: string;
function BoolToStr(boo: Boolean): string;
function IntToSex(INT: Integer): string;
function IntToJob(INT: Integer): string;
function IntToStr2(INT: Integer): string;
function BoolToCStr(boo: Boolean): string;
function BoolToIntStr(boo: Boolean): string;
function TagCount(Source: string; Tag: Char): Integer;
function _MIN(n1, n2: Integer): Integer;
function _MAX(n1, n2: Integer): Integer;
function _MAX1(n1, n2: Integer): Integer;
function CalcFileCRC(FileName: string): Integer;
function CalcBufferCRC(Buffer: PChar; nSize: Integer): Integer;
function IsIPaddr(IP: string): Boolean;
function GetDayCount(MaxDate, MinDate: TDateTime): Integer;
function GetCodeMsgSize(x: Double): Integer;
function GetBit(value:Byte;which:Byte):Byte;
function _Copy(str:String;Index,COunt:Integer):String;
implementation

//var
//	CSUtilLock: TRTLCriticalSection;
function GetBit(value:Byte;which:Byte):Byte;
begin
   if which=0 then
      Result:=(value and $F0) shr 4
   else
      Result:=value and $f;
end;
function IsIPaddr(IP: string): Boolean;
var
  Node                                  : array[0..3] of Integer;
  tIP                                   : string;
  tNode                                 : string;
  tPos                                  : Integer;
  tLen                                  : Integer;
begin
  Result := False;
  tIP := IP;
  tLen := length(tIP);
  tPos := Pos('.', tIP);
  tNode := MidStr(tIP, 1, tPos - 1);
  tIP := MidStr(tIP, tPos + 1, tLen - tPos);
  if not TryStrToInt(tNode, Node[0]) then
    exit;

  tLen := length(tIP);
  tPos := Pos('.', tIP);
  tNode := MidStr(tIP, 1, tPos - 1);
  tIP := MidStr(tIP, tPos + 1, tLen - tPos);
  if not TryStrToInt(tNode, Node[1]) then
    exit;

  tLen := length(tIP);
  tPos := Pos('.', tIP);
  tNode := MidStr(tIP, 1, tPos - 1);
  tIP := MidStr(tIP, tPos + 1, tLen - tPos);
  if not TryStrToInt(tNode, Node[2]) then
    exit;

  if not TryStrToInt(tIP, Node[3]) then
    exit;
  for tLen := Low(Node) to High(Node) do
  begin
    if (Node[tLen] < 0) or (Node[tLen] > 255) then
      exit;
  end;
  Result := True;
end;

function CalcFileCRC(FileName: string): Integer;
var
  i                                     : Integer;
  nFileHandle                           : Integer;
  nFileSize, nBuffSize                  : Integer;
  Buffer                                : PChar;
  INT                                   : ^Integer;
  nCrc                                  : Integer;
begin
  Result := 0;
  if not FileExists(FileName) then
  begin
    exit;
  end;
  nFileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
  if nFileHandle = 0 then
    exit;
  nFileSize := FileSeek(nFileHandle, 0, 2);
  nBuffSize := (nFileSize div 4) * 4;
  GetMem(Buffer, nBuffSize);
  FillChar(Buffer^, nBuffSize, 0);
  FileSeek(nFileHandle, 0, 0);
  FileRead(nFileHandle, Buffer^, nBuffSize);
  FileClose(nFileHandle);
  INT := Pointer(Buffer);
  nCrc := 0;
  Exception.Create(IntToStr(SizeOf(Integer)));
  for i := 0 to nBuffSize div 4 - 1 do
  begin
    nCrc := nCrc xor INT^;
    INT := Pointer(Integer(INT) + 4);
  end;
  FreeMem(Buffer);
  Result := nCrc;
end;

function CalcBufferCRC(Buffer: PChar; nSize: Integer): Integer;
var
  i                                     : Integer;
  INT                                   : ^Integer;
  nCrc                                  : Integer;
begin
  INT := Pointer(Buffer);
  nCrc := 0;
  for i := 0 to nSize div 4 - 1 do
  begin
    nCrc := nCrc xor INT^;
    INT := Pointer(Integer(INT) + 4);
  end;
  Result := nCrc;
end;
{ capture "double quote streams" }

function CaptureString(Source: string; var rdstr: string): string;
var
  st, et, C, Len, i                     : Integer;
begin
  if Source = '' then
  begin
    rdstr := '';
    Result := '';
    exit;
  end;
  C := 1;
  //et := 0;
  Len := length(Source);
  while Source[C] = ' ' do
    if C < Len then
      Inc(C)
    else
      break;

  if ((Source[C] = '"') or (Source[C] = '(')) and (C < Len) then
  begin

    st := C + 1;
    et := Len;
    for i := C + 1 to Len do
      if (Source[i] = '"') or (Source[i] = ')') then
      begin
        et := i - 1;
        break;
      end;

  end
  else
  begin
    st := C;
    et := Len;
    for i := C to Len do
      if Source[i] = ' ' then
      begin
        et := i - 1;
        break;
      end;

  end;

  rdstr := Copy(Source, st, (et - st + 1));
  if Len >= (et + 2) then
    Result := Copy(Source, et + 2, Len - (et + 1))
  else
    Result := '';

end;



function CountUglyWhiteChar(sPtr: PChar): LongInt;
var
  Cnt, Killw                            : LongInt;
begin
  Killw := 0;
  for Cnt := (StrLen(sPtr) - 1) downto 0 do
  begin
    if sPtr[Cnt] = ' ' then
    begin
      Inc(Killw);
      {sPtr[Cnt] := #0;}
    end
    else
      break;
  end;
  Result := Killw;
end;


function CountGarbage(paper: TCanvas; Src: PChar; TargWidth: LongInt): Integer;
{garbage}
var
  gab, destWidth                        : Integer;
begin

  gab := CountUglyWhiteChar(Src);
  destWidth := paper.TextWidth(StrPas(Src)) - gab;
  Result := TargWidth - destWidth + (gab * paper.TextWidth(' '));

end;


function GetSpaceCount(str: string): LongInt;
var
  Cnt, Len, SpaceCount                  : LongInt;
begin
  SpaceCount := 0;
  Len := length(str);
  for Cnt := 1 to Len do
    if str[Cnt] = ' ' then
      SpaceCount := SpaceCount + 1;
  Result := SpaceCount;
end;

function RemoveSpace(str: string): string;
var
  i                                     : Integer;
begin
  Result := '';
  for i := 1 to length(str) do
    if str[i] <> ' ' then
      Result := Result + str[i];
end;

function KillFirstSpace(var str: string): LongInt;
var
  Cnt, Len                              : LongInt;
begin
  Result := 0;
  Len := length(str);
  for Cnt := 1 to Len do
    if str[Cnt] <> ' ' then
    begin
      str := Copy(str, Cnt, Len - Cnt + 1);
      Result := Cnt - 1;
      break;
    end;
end;

procedure KillGabageSpace(var str: string);
var
  Cnt, Len                              : LongInt;
begin
  Len := length(str);
  for Cnt := Len downto 1 do
    if str[Cnt] <> ' ' then
    begin
      str := Copy(str, 1, Cnt);
      KillFirstSpace(str);
      break;
    end;
end;

function GetFirstWord(str: string; var sWord: string; var FrontSpace: LongInt):
  string;
var
  Cnt, Len, n                           : LongInt;
  DestBuf                               : Str4096;
begin
  Len := length(str);
  if Len <= 0 then
    Result := ''
  else
  begin
    FrontSpace := 0;
    for Cnt := 1 to Len do
    begin
      if str[Cnt] = ' ' then
        Inc(FrontSpace)
      else
        break;
    end;
    n := 0;
    for Cnt := Cnt to Len do
    begin
      if str[Cnt] <> ' ' then
        DestBuf[n] := str[Cnt]
      else
      begin
        DestBuf[n] := #0;
        sWord := StrPas(DestBuf);
        Result := Copy(str, Cnt, Len - Cnt + 1);
        exit;
      end;
      Inc(n);
    end;
    DestBuf[n] := #0;
    sWord := StrPas(DestBuf);
    Result := '';
  end;
end;

function HexToIntEx(shap_str: string): LongInt;
begin
  Result := HexToInt(Copy(shap_str, 2, length(shap_str) - 1));
end;

function HexToInt(str: string): LongInt;
var
  digit                                 : Char;
  Count, i                              : Integer;
  cur, val                              : LongInt;
begin
  val := 0;
  Count := length(str);
  for i := 1 to Count do
  begin
    digit := str[i];
    if (digit >= '0') and (digit <= '9') then
      cur := Ord(digit) - Ord('0')
    else if (digit >= 'A') and (digit <= 'F') then
      cur := Ord(digit) - Ord('A') + 10
    else if (digit >= 'a') and (digit <= 'f') then
      cur := Ord(digit) - Ord('a') + 10
    else
      cur := 0;
    val := val + (cur shl (4 * (Count - i)));
  end;
  Result := val;
  //   Result := (Val and $0000FF00) or ((Val shl 16) and $00FF0000) or ((Val shr 16) and $000000FF);
end;

function Str_ToInt(str: string; Def: LongInt): LongInt;
var
  v, code                               : LongInt;

begin
  Result := Def;
  val(str, v, code);
  if code = 0 then
    Result := v;
  {
  if str <> '' then
  begin
    if ((Word(str[1]) >= Word('0')) and (Word(str[1]) <= Word('9'))) or
      (str[1] = '+') or (str[1] = '-') then
    try
      Result := StrToInt64(str);
    except
    end;
  end;
  }
end;

function Str_ToDate(str: string): TDateTime;
begin
  if Trim(str) = '' then
    Result := Date
  else
    Result := StrToDate(str);
end;
function Str_ToDateTime(str: string): TDateTime;
begin
  if Trim(str) = '' then
    Result := Date
  else
    Result := StrToDateTime(str);
end;

function Str_ToTime(str: string): TDateTime;
begin
  if Trim(str) = '' then
    Result := Time
  else
    Result := StrToTime(str);
end;

function Str_ToFloat(str: string): real;
begin
  if str <> '' then
  try
    Result := StrToFloat(str);
    exit;
  except
  end;
  Result := 0;
end;

procedure DrawingGhost(Rc: TRect);
var
  DC                                    : hdc;
begin
  DC := GetDC(0);
  DrawFocusRect(DC, Rc);
  ReleaseDC(0, DC);
end;

function ExtractFileNameOnly(const fname: string): string;
var
  extpos                                : Integer;
  ext, fn                               : string;
begin
  ext := ExtractFileExt(fname);
  fn := ExtractFileName(fname);
  if ext <> '' then
  begin
    extpos := Pos(ext, fn);
    Result := Copy(fn, 1, extpos - 1);
  end
  else
    Result := fn;
end;

function FloatToString(F: real): string;
begin
  Result := FloatToStrFixFmt(F, 5, 2);
end;

function FloatToStrFixFmt(fVal: Double; prec, digit: Integer): string;
var
  Cnt, Dest, Len, i, j                  : Integer;
  fstr                                  : string;
  Buf                                   : array[0..255] of Char;
label
  end_conv;
begin
  Cnt := 0;
  Dest := 0;
  fstr := FloatToStrF(fVal, ffGeneral, 15, 3);
  Len := length(fstr);
  for i := 1 to Len do
  begin
    if fstr[i] = '.' then
    begin
      Buf[Dest] := '.';
      Inc(Dest);
      Cnt := 0;
      for j := i + 1 to Len do
      begin
        if Cnt < digit then
        begin
          Buf[Dest] := fstr[j];
          Inc(Dest);
        end
        else
        begin