hutil32.pas

传世源码可编译的,功能齐全.是学习的好模版,会DELPHI的朋友们也可以自己修改,弄个自己的引擎.

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
               goto end_conv;
            end;
            Inc(cnt);
         end;
         goto end_conv;
      end;
      if cnt < prec then begin
         Buf[dest] := fstr[i]; Inc(dest);
      end;
      Inc(cnt);
   end;
   end_conv:
   Buf[dest] := char(0);
   Result := strPas(Buf);
end;


function  FileSize (const FName: string): Longint;
var
  SearchRec: TSearchRec;
begin
  if FindFirst(ExpandFileName(FName), faAnyFile, SearchRec) = 0 then
    Result := SearchRec.Size
  else Result := -1;
end;


function FileCopy(source,dest: String): Boolean;
var
  fSrc,fDst,len: Integer;
  size: Longint;
  buffer: packed array [0..2047] of Byte;
begin
  Result := False; { Assume that it WONT work }
  if source <> dest then begin
    fSrc := FileOpen(source,fmOpenRead);
    if fSrc >= 0 then begin
      size := FileSeek(fSrc,0,2);
      FileSeek(fSrc,0,0);
      fDst := FileCreate(dest);
      if fDst >= 0 then begin
        while size > 0 do begin
          len := FileRead(fSrc,buffer,sizeof(buffer));
          FileWrite(fDst,buffer,len);
          size := size - len;
        end;
        FileSetDate(fDst,FileGetDate(fSrc));
        FileClose(fDst);
        FileSetAttr(dest,FileGetAttr(source));
        Result := True;
      end;
      FileClose(fSrc);
    end;
  end;
end;

function FileCopyEX(source,dest: String): Boolean;
var
  fSrc,fDst,len: Integer;
  size: Longint;
  buffer: array [0..512000] of Byte;
begin
  Result := False; { Assume that it WONT work }
  if source <> dest then begin
    fSrc := FileOpen(source,fmOpenRead or fmShareDenyNone);
    if fSrc >= 0 then begin
      size := FileSeek(fSrc,0,2);
      FileSeek(fSrc,0,0);
      fDst := FileCreate(dest);
      if fDst >= 0 then begin
        while size > 0 do begin
          len := FileRead(fSrc,buffer,sizeof(buffer));
          FileWrite(fDst,buffer,len);
          size := size - len;
        end;
        FileSetDate(fDst,FileGetDate(fSrc));
        FileClose(fDst);
        FileSetAttr(dest,FileGetAttr(source));
        Result := True;
      end;
      FileClose(fSrc);
    end;
  end;
end;


function GetDefColorByName (Str: string): TColor;
var
	Cnt: Integer;
   COmpStr: string;
begin
	compStr := UpperCase (str);
	for Cnt := 1 to MAXDEFCOLOR do begin
   	if CompStr = ColorNames[Cnt].Name then begin
      	Result := TColor (ColorNames[Cnt].varl);
         exit;
      end;
   end;
   result := $0;
end;

function GetULMarkerType (Str: string): Longint;
var
	Cnt: Integer;
   COmpStr: string;
begin
	compStr := UpperCase (str);
	for Cnt := 1 to MAXLISTMARKER do begin
   	if CompStr = LiMarkerNames[Cnt].Name then begin
      	Result := LiMarkerNames[Cnt].varl;
         exit;
      end;
   end;
   result := 1;
end;

function GetDefines (Str: string): Longint;
var
	Cnt: Integer;
   COmpStr: string;
begin
	compStr := UpperCase (str);
	for Cnt := 1 to MAXPREDEFINE do begin
   	if CompStr = PreDefineNames[Cnt].Name then begin
      	Result := PreDefineNames[Cnt].varl;
         exit;
      end;
   end;
   result := -1;
end;

procedure ClearWindow (aCanvas: TCanvas; aLeft, aTop, aRight, aBottom:Longint; aColor: TColor);
begin
   with aCanvas do begin
      Brush.Color := aColor;
      Pen.Color 	:= aColor;
   	Rectangle (0, 0, aRight-aLeft, aBottom-aTop);
   end;
end;


procedure DrawTileImage (Canv: TCanvas; Rect: TRect; TileImage: TBitmap);
var
   I, J, ICnt, JCnt, BmWidth, BmHeight: Integer;
begin

   BmWidth  := TileImage.Width;
   BmHeight := TileImage.Height;
   ICnt 		:= ((Rect.Right-Rect.Left) + BmWidth - 1) div BmWidth;
   JCnt 		:= ((Rect.Bottom-Rect.Top) + BmHeight - 1) div BmHeight;

   UnrealizeObject (Canv.Handle);
   SelectPalette (Canv.Handle, TileImage.Palette, FALSE);
   RealizePalette (Canv.Handle);

   for J:=0 to JCnt do begin
      for I:=0 to ICnt do begin

        { if (I * BmWidth) < (Rect.Right-Rect.Left) then
          	BmWidth := TileImage.Width else
            BmWidth := (Rect.Right - Rect.Left) - ((I-1) * BmWidth);

         if (
         BmWidth := TileImage.Width;
         BmHeight := TileImage.Height;  }

         BitBlt (Canv.Handle,
                 Rect.Left + I * BmWidth,
                 Rect.Top + (J * BmHeight),
                 BmWidth,
                 BmHeight,
                 TileImage.Canvas.Handle,
                 0,
                 0,
                 SRCCOPY);

      end;
   end;

end;


procedure TiledImage (Canv: TCanvas; Rect: TLRect; TileImage: TBitmap);
var
   I, J, ICnt, JCnt, BmWidth, BmHeight: Integer;
   Rleft, RTop, RWidth, RHeight, BLeft, BTop: longint;
begin

	if Assigned (TileImage) then
   	if TileImage.Handle <> 0 then begin

         BmWidth  := TileImage.Width;
         BmHeight := TileImage.Height;
         ICnt 		:= (Rect.Right + BmWidth - 1) div BmWidth  -  (Rect.Left div BmWidth);
         JCnt 		:= (Rect.Bottom + BmHeight - 1) div BmHeight -  (Rect.Top div BmHeight);

         UnrealizeObject (Canv.Handle);
         SelectPalette (Canv.Handle, TileImage.Palette, FALSE);
         RealizePalette (Canv.Handle);

         for J:=0 to JCnt do begin
            for I:=0 to ICnt do begin

               if I = 0 then begin
                  BLeft := Rect.Left - ((Rect.Left div BmWidth) * BmWidth);
                  RLeft := Rect.Left;
                  RWidth := BmWidth;
               end else begin
                  if I = ICnt then
                     RWidth := Rect.Right - ((Rect.Right div BmWidth) * BmWidth) else
                     RWidth := BmWidth;
                  BLeft := 0;
                  RLeft := (Rect.Left div BmWidth) + (I * BmWidth);
               end;


               if J = 0 then begin
                  BTop := Rect.Top - ((Rect.Top div BmHeight) * BmHeight);
                  RTop := Rect.Top;
                  RHeight := BmHeight;
               end else begin
                  if J = JCnt then
                     RHeight := Rect.Bottom - ((Rect.Bottom div BmHeight) * BmHeight) else
                     RHeight := BmHeight;
                  BTop := 0;
                  RTop := (Rect.Top div BmHeight) + (J * BmHeight);
               end;

               BitBlt (Canv.Handle,
                       RLeft,
                       RTop,
                       RWidth,
                       RHeight,
                       TileImage.Canvas.Handle,
                       BLeft,
                       BTop,
                       SRCCOPY);

            end;
         end;

   	end;
end;


function GetValidStr3 (Str: string; var Dest: string; const Divider: array of Char): string;
const
   BUF_SIZE = 20480; //$7FFF;
var
	Buf: array[0..BUF_SIZE] of char;
   BufCount, Count, SrcLen, I, ArrCount: Longint;
   Ch: char;
label
	CATCH_DIV;
begin
   try
      SrcLen := Length(Str);
      BufCount := 0;
      Count := 1;

      if SrcLen >= BUF_SIZE-1 then begin
         Result := '';
         Dest := '';
         exit;
      end;

      if Str = '' then begin
         Dest := '';
         Result := Str;
         exit;
      end;
      ArrCount := sizeof(Divider) div sizeof(char);

      while TRUE do begin
         if Count <= SrcLen then begin
            Ch := Str[Count];
            for I:=0 to ArrCount- 1 do
               if Ch = Divider[I] then
                  goto CATCH_DIV;
         end;
         if (Count > SrcLen) then begin
            CATCH_DIV:
            if (BufCount > 0) then begin
               if BufCount < BUF_SIZE-1 then begin
                  Buf[BufCount] := #0;
                  Dest :=  string(Buf); 
                  Result := Copy (Str, Count+1, SrcLen-Count);
               end;
               break;
            end else begin
               if (Count > SrcLen) then begin
                  Dest := '';
                  Result := Copy (Str, Count+2, SrcLen-1);
                  break;
               end;
            end;
         end else begin
            if BufCount < BUF_SIZE-1 then begin
               Buf[BufCount] := Ch;
               Inc (BufCount);
            end;// else
               //ShowMessage ('BUF_SIZE overflow !');
         end;
         Inc (Count);
      end;
   except
      Dest := '';
      Result := '';
   end;
end;


// 备盒巩磊啊 唱赣瘤(Result)俊 器窃 等促.
function GetValidStr4 (Str: string; var Dest: string; const Divider: array of Char): string;
const
   BUF_SIZE = 18200; //$7FFF;
var
	Buf: array[0..BUF_SIZE] of char;
   BufCount, Count, SrcLen, I, ArrCount: Longint;
   Ch: char;
label
	CATCH_DIV;
begin
	try
   	//EnterCriticalSection (CSUtilLock);
      SrcLen := Length(Str);
      BufCount := 0;
      Count := 1;

      if Str = '' then begin
         Dest := '';
         Result := Str;
         exit;
      end;
      ArrCount := sizeof(Divider) div sizeof(char);

      while TRUE do begin
         if Count <= SrcLen then begin
            Ch := Str[Count];
            for I:=0 to ArrCount- 1 do
               if Ch = Divider[I] then
                  goto CATCH_DIV;
         end;
         if (Count > SrcLen) then begin
            CATCH_DIV:
            if (BufCount > 0) or (Ch <> ' ') then begin
               if BufCount <= 0 then begin
                  Buf[0] := Ch; Buf[1] := #0; Ch := ' ';
               end else
                  Buf[BufCount] := #0;
               Dest := string (Buf);
               if Ch <> ' ' then
                  Result := Copy (Str, Count, SrcLen-Count+1)        //remain divider in rest-string,
               else Result := Copy (Str, Count+1, SrcLen-Count);   //exclude whitespace
               break;
            end else begin
               if (Count > SrcLen) then begin
                  Dest := '';
                  Result := Copy (Str, Count+2, SrcLen-1);
                  break;
               end;
            end;
         end else begin
            if BufCount < BUF_SIZE-1 then begin
               Buf[BufCount] := Ch;
               Inc (BufCount);
            end else
               ShowMessage ('BUF_SIZE overflow !');     
         end;
         Inc (Count);
      end;
	finally
      //LeaveCriticalSection (CSUtilLock);
	end;      
end;


function GetValidStrVal (Str: string; var Dest: string; const Divider: array of Char): string;
//箭磊甫 盒府秦晨 ex) 12.30mV
const
	BUF_SIZE = 15600;
var
	Buf: array[0..BUF_SIZE] of char;
   BufCount, Count, SrcLen, I, ArrCount: Longint;
   Ch: char;
   currentNumeric: Boolean;
   hexmode: Boolean;
label
	CATCH_DIV;
begin
	try
   	//EnterCriticalSection (CSUtilLock);
      hexmode := FALSE;
      SrcLen := Length(Str);
      BufCount := 0;
      Count := 1;
      currentNumeric := FALSE;

      if Str = '' then begin
         Dest := '';
         Result := Str;
         exit;
      end;
      ArrCount := sizeof(Divider) div sizeof(char);

      while TRUE do begin
         if Count <= SrcLen then begin
            Ch := Str[Count];
            for I:=0 to ArrCount- 1 do
               if Ch = Divider[I] then
                  goto CATCH_DIV;
         end;
         if not currentNumeric then begin
            if (Count+1) < SrcLen then begin
               if (Str[Count] = '0') and (UpCase(Str[Count+1]) = 'X') then begin
                  Buf[BufCount] := Str[Count];
                  Buf[BufCount+1] := Str[Count+1];
                  Inc (BufCount, 2);
                  Inc (Count, 2);
                  hexmode := TRUE;
                  currentNumeric := TRUE;
                  continue;
               end;
               if (Ch = '-') and (Str[Count+1] >= '0') and (Str[Count+1] <= '9') then begin
                  currentNumeric := TRUE;
               end;
            end;
            if (Ch >= '0') and (Ch <= '9') then begin
               currentNumeric := TRUE;
            end;
         end else begin
            if hexmode then begin
               if not (((Ch >= '0') and (Ch <= '9')) or
                       ((Ch >= 'A') and (Ch <= 'F')) or
                       ((Ch >= 'a') and (Ch <= 'f'))) then begin
                     Dec (Count);
                     goto CATCH_DIV;
               end;
            end else
               if ((Ch < '0') or (Ch > '9')) and (Ch <> '.') then begin
                  Dec (Count);
                  goto CATCH_DIV;
               end;
         end;
         if (Count > SrcLen) then begin
            CATCH_DIV:
            if (BufCount > 0) then begin
               Buf[BufCount] := #0;
               Dest := string (Buf);
               Result := Copy (Str, Count+1, SrcLen-Count);
               break;
            end else begin
               if (Count > SrcLen) then begin
                  Dest := '';
                  Result := Copy (Str, Count+2, SrcLen-1);
                  break;
               end;
            end;
         end else begin
            if BufCount < BUF_SIZE-1 then begin
               Buf[BufCount] := Ch;
               Inc (BufCount);
            end else
               ShowMessage ('BUF_SIZE overflow !');
         end;
         Inc (Count);
      end;
	finally
   	//LeaveCriticalSection (CSUtilLock);
	end;
end;