fccommon.pas

一套及时通讯的原码

   end;
begin
  if not fcStrToFloat2(str, result, DisplayFormat) then
     result:= 0;
//  result:= fcStrToRealDef(stripcomma(str),0.00);
end;

function fcStrToRealDef(const S: string; Default: Extended): Real;
var E: Integer;
begin
  Val(S, Result, E);
  if E <> 0 then Result := Default
end;

{ Return true if class is derived from 'Name' }
{ This code is more code efficient than InheritsFrom or 'Is'
  as it does not require that the compiler link in the class }
function fcIsClass(ClassType: TClass; const Name: string): Boolean;
begin
  Result := True;
  while ClassType <> nil do
  begin
{    if ClassType.ClassNameIs(Name) then Exit;}
    if uppercase(ClassType.ClassName)=uppercase(Name) then Exit;
    ClassType := ClassType.ClassParent;
  end;
  Result := False;
end;

function fcParentGridFocused(AControl:TControl): boolean;
begin
   result:= False;
   if fcIsClass(AControl.Parent.ClassType, 'TwwDBGrid') then
      if AControl.Parent.Focused then result:= True
end;

function fcIsInwwGrid(AControl: TControl): Boolean;
begin
  result := False;
  if AControl.Parent = nil then Exit;

  if fcIsClass(AControl.Parent.ClassType, 'TCustomGrid') then { 6/28/99 - Support any TCustomGrid }
    result := True;
end;

{$ifdef fcDelphi4Up}
function fcIsInwwObjectView(control: TWinControl):boolean;
begin
  result := False;
  if fcisClass(control.Parent.classType, 'TwwDataInspector') then
     result := True;
end;

function fcIsInwwObjectViewPaint(control: TWinControl):boolean;
begin
  result := False;
  if fcisClass(control.Parent.classType, 'TwwDataInspector') then
     if csPaintCopy in control.ControlState then
        result := True;
end;

function fcIsInwwGridPaint(control: TWinControl):boolean;
begin
  result := False;
  if fcisClass(control.Parent.classType, 'TCustomGrid') then
     if csPaintCopy in control.ControlState then
        result := True;
end;
{$endif}

function fcGetGridOptions(AControl:TControl): TwwDBGridOptions;
begin
  Result := [];
  if fcIsClass(AControl.Parent.ClassType, 'TwwDBGrid') then
    PChar(@result)^ := Char(fcGetOrdProp(AControl.Parent, 'Options'));
end;

// String Functions for stripping out spaces
procedure fcStripPreceding(var s: string);
  var i,len: integer;
begin
  i:= 1;
  len:= length(s);
  while (i<=length(s)) and (s[i] in [' ',#9]) do i:= i+1;
  if ((len<>0) and (i<=len)) then
     s:= copy(s,i,len-i+1)
  else if (len<>0) then s:='';
end;

procedure fcStripTrailing(var s: string);
  var len: integer;
begin
  len := length(s);
  while (len > 0) and (s[len] in [' ', #9]) do len := len - 1;
  SetLength(s, len);
end;

Procedure fcStripWhiteSpace(var s: string);
  var tempstr: string;
begin
  tempstr := s;
  fcStripPreceding(tempstr);
  fcStripTrailing(tempstr);
  s := tempstr;
end;

{Gets the Byte Values for a color independent of order of Color}
procedure fcColorToByteValues(AColor: TColor; var Reserved, Blue, Green, Red: Byte);
var WinColor: COLORREF;
begin
  WinColor := ColorToRGB(AColor);
  Reserved := ($FF000000 and WinColor) Shr 24;
  Blue := ($00FF0000 and WinColor) Shr 16;
  Green := ($0000FF00 and WinColor) Shr 8;
  Red := ($000000FF and WinColor);
end;

function fcRGBToHexString(R,G,B:Byte):String;
begin
  result := Format('%2.2x%2.2x%2.2x',[R,G,B]);
end;

function fcColorToRGBString(AColor: TColor): string;
var red1,blue1,green1,reserved:byte;
begin
  fcColorToByteValues(AColor,reserved,blue1,green1,red1);
  result := 'RGB: '+IntToStr(red1)+', '
                   +IntToStr(green1) + ', '
                   +IntToStr(blue1);
end;

function fcGetItemsFromStringList(SList:TStrings;Index:integer): String;
begin
   result := SList.Strings[Index];
end;

function fcGetNamesFromStringList(AList:TStrings;Index:integer): String;
begin
   result := '';
   if (Index <> -1) then  result := AList.Names[Index];
end;

function fcGetValuesFromStringList(AList:TStrings;Index: Integer): string;
var temps:string;
begin
  temps:=AList.Strings[Index];   //List is in RGB already...
  temps := Copy(temps,pos('=',temps)+1,length(temps));
  fcStripWhiteSpace(temps);
  result :=Temps;
end;

function fcGetColorFromList(AList:TStrings;Index: Integer): TColor;
var temps:string;
begin
   temps := fcGetValuesFromStringList(AList,Index);
   result := StringToColor('$'+temps);
end;

{Returns -1 if ColorValue is not found in the list;
 otherwise returns the index position in the list}
function fcValueInList(Value: string; List: TStrings): integer;
var i: integer;
begin
  result := -1;
  for i := 0 to List.Count - 1 do
    if fcGetValuesFromStringList(List,i) = Value then begin result := i; break; end;
end;

function fcNameInList(Name: string; List: TStrings): integer;
var i: integer;
begin
  result := -1;
  for i := 0 to List.Count - 1 do
    if AnsiUppercase(List.Names[i]) = AnsiUppercase(Name) then { RSW }
    begin
      result := i;
      break;
    end;
end;

function fcSetColorDialogCustomColors(AList:TStrings):TStrings;
var sList:TStringList;
    i:Integer;
begin
  sList := TStringList.Create;
  for i:= ord('A') to ord('P') do
     sList.Add('Color'+Char(i)+'='+AList.Values[AList.Names[i-ord('A')]]);
  result := sList;
end;

procedure fcQuickSort(SList: TStrings; L, R: Integer;
  SCompare: TwwListSortCompare; SGetString:TwwGetCompareString);
  var
    I, J: Integer;
    P, T: String;
begin
    repeat
      I := L;
      J := R;
      P := SGetString(SList,((L + R) shr 1));
      repeat
        while (i<=SList.count-1) and(SCompare(SGetString(SList,I), P) < 0) do
           Inc(I);
        while (j>=0) and (SCompare(SGetString(SList,J), P) > 0) do Dec(J);
        if I <= J then
        begin
          T := SList[I];
          SList[I] := SList[J];
          SList[J] := T;
          Inc(I);
          Dec(J);
        end;
      until I > J;
      if L < J then fcQuickSort(SList, L, J, SCompare, SGetString);
      L := I;
    until I >= R;
end;

function fcIsTrueColorBitmap(Bitmap: TBitmap): boolean;
begin
  result:= Bitmap.PixelFormat = Graphics.pf24bit;
end;

function fcBytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
begin
  Dec(Alignment);
  Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
  Result := Result div 8;
end;

// This function creates a HBitmap that must be deleted using DeleteObject by the caller
function fcGetDIBBitsFromBitmap(aBitmap: TBITMAP; var BitmapInfo:TBitmapInfo; var pixbuf:Pointer; var bytespscanline:Integer; var Hb:HBitmap): Boolean;
begin
  FillChar(BitmapInfo, SizeOf(TBitmapInfo), 0);
  with BitmapInfo.bmiheader do
  begin
    biSize := sizeof(TBitmapInfoHeader);
    biWidth := ABitmap.Width;
    biHeight := -ABitmap.Height;   //DIBs are Bottom up
    biPlanes :=1;
    biBitCount := 24;
    biCompression := BI_RGB;
    bytespscanline := fcBytesPerScanline(LongInt(biwidth),biBitCount, 32);
  end;

  hb := CreateDIBSection(ABitmap.Canvas.Handle, BitmapInfo, DIB_RGB_COLORS, pixbuf, 0, 0);

  if (pixbuf = nil) or (hb = 0) then
  begin
    raise EInvalidOperation.Create('Could Not Create DIB Section');
    Exit;
  end;

  GetDIBits(ABitmap.Canvas.Handle, aBitmap.handle, 0, ABitmap.height, pixbuf, BitmapInfo, DIB_RGB_COLORS);
  result := True;
end;

type TNewImageList = class(TImageList);

function fcCreateRegionFromBitmap(ABitmap: TBitmap; TransColor: TColor): HRgn;
var
  TempBitmap: TBitmap;
  Rgn1, Rgn2: HRgn;
  Col, StartCol, Row: integer;
  Line: PByteArray;

  function ColToColor(Col: integer): TColor;
  begin
    if fcIsTrueColorBitmap(TempBitmap) then
      result:= Line[Col * 3] * 256 * 256 + Line[Col * 3 + 1] * 256 + Line[Col * 3 + 2]
    else result := TColor(fcThisThat((Line[Col div 8] and BitMask[Col mod 8]) <> 0, clBlack, clWhite));
  end;
begin
  result := 0;
  if (ABitmap <> nil) and (ABitmap.Width = 0) or (ABitmap.Height = 0) then Exit;
  Rgn1 := 0;

  TempBitmap := TBitmap.Create;

  TempBitmap.Assign(ABitmap);
  if not fcIsTrueColorBitmap(TempBitmap) then
  begin
    TempBitmap.Mask(TransColor);
    TransColor := clBlack;
  end;

  with TempBitmap do
  begin
    for Row := 0 to TempBitmap.height-1 do
    begin
      Line:= scanLine[row];

      Col := 0;
      while Col < TempBitmap.Width do
      begin
        while (Col < TempBitmap.Width) and (ColToColor(Col) = TransColor) do inc(Col);
        if Col >= TempBitmap.Width then Continue;

        StartCol := Col;
        while (Col < TempBitmap.Width) and (ColToColor(Col) <> TransColor) do inc(Col);
        if Col >= TempBitmap.Width then Col := TempBitmap.Width;

        if Rgn1 = 0 then Rgn1 := CreateRectRgn(StartCol, Row, Col, Row + 1)
        else begin
          Rgn2 := CreateRectRgn(StartCol, Row, Col, Row + 1);
          if (Rgn2 <> 0) then CombineRgn(Rgn1,Rgn1,Rgn2,RGN_OR);
            Deleteobject(Rgn2);
        end;
      end;
    end;
  end;
  result := Rgn1;
  TempBitmap.Free;
end;

function fcRegionFromBitmap(ABitmap: TfcBitmap; TransColor: TColor): HRgn;
type PCOLORREF = ^COLORREF;
var
  Rgn1, Rgn2: HRgn;
  Col, StartCol, Row: integer;
begin
  result := 0;
  if (ABitmap <> nil) and (ABitmap.Width = 0) or (ABitmap.Height = 0) then Exit;
  Rgn1 := 0;

  if TransColor = -1 then TransColor := fcGetStdColor(ABitmap.Pixels[0, 0]);

  with ABitmap do
  begin
    for Row := 0 to Height - 1 do
    begin
      Col := 0;
      while Col < Width do
      begin
        while (Col < Width) and (fcGetStdColor(Pixels[Row, Col]) = TransColor) do
          inc(Col);
        if Col >= Width then Continue;

        StartCol := Col;
        while (Col < Width) and (fcGetStdColor(Pixels[Row, Col]) <> TransColor) do inc(Col);
        if Col >= Width then Col := Width;

        if Rgn1 = 0 then Rgn1 := CreateRectRgn(StartCol, Row, Col, Row + 1)
        else begin
          Rgn2 := CreateRectRgn(StartCol, Row, Col, Row + 1);
          if (Rgn2 <> 0) then CombineRgn(Rgn1,Rgn1,Rgn2,RGN_OR);
            Deleteobject(Rgn2);
        end;
      end;
    end;
  end;
  result := Rgn1;
end;

procedure fcSetDitherBitmap(DitherBitmap: TBitmap;
  Color1, Color2: TColor);
var i, j: Integer;
begin
{  if (Screen.ActiveForm<>nil) and (Screen.ActiveForm.Canvas.Handle<>0) then
  begin
     if GetDeviceCaps(Screen.ActiveForm.canvas.handle, BITSPIXEL)<=4 then
        DitherBitmap.LoadFromResourceName(HINSTANCE, 'SELECTIONBRUSH')
     else DitherBitmap.LoadFromResourceName(HINSTANCE, 'SELECTIONBRUSH256');
  end
  else}
  DitherBitmap.LoadFromResourceName(HINSTANCE, 'SELECTIONBRUSH');

  for i := 0 to DitherBitmap.Width - 1 do
    for j := 0 to DitherBitmap.Height - 1 do
      if (i + j) mod 2 = 0 then DitherBitmap.Canvas.Pixels[i, j] := clWhite
      else DitherBitmap.Canvas.Pixels[i, j] := clBlack;
  DitherBitmap.Monochrome := True;
end;

function fcMin(Int1, Int2: Integer): Integer;
begin
  if Int1 < Int2 then result := Int1 else result := Int2;
end;

function fcMinFloat(Int1, Int2: Double): Double;
begin
  if Int1 < Int2 then result := Int1 else result := Int2;
end;

function fcMax(Int1, Int2: Integer): Integer;
begin
  if Int1 > Int2 then result := Int1 else result := Int2;
end;

function fcMaxFloat(Int1, Int2: Double): Double;
begin
  if Int1 > Int2 then result := Int1 else result := Int2;
end;

function fcLimit(Val: integer; Int1, Int2: Integer): Integer;
begin
   val:= fcMax(val, int1);
   val:= fcMin(val, int2);
   result:= val;
end;

procedure fcPlayKeystroke(Handle: HWND; VKChar: word; VKShift: Word);
var
  KeyState: TKeyboardState;