fccommon.pas

一套及时通讯的原码

        OrigRect.Right + Trunc((FinalRect.Right - OrigRect.Right) * Percent),
        OrigRect.Bottom + Trunc((FinalRect.Bottom - OrigRect.Bottom) * Percent)
      );
      if Assigned(SetBoundsProc) then SetBoundsProc(Control, R) else Control.BoundsRect := R;
    end;
  end;

  procedure Animate;
  var i: Integer;
  begin
    Percent := FStep / Steps;
    for i := 0 to AnimateList.Count - 1 do with TfcGroupAnimateItem(AnimateList[i]) do
    begin
      SetBounds(MainItem);
      if SecondItem <> nil then SetBounds(SecondItem);
    end;
  end;
begin
  if AnimateList.Count > 0 then for FStep := 1 to Steps do
  begin
    Animate;
//    if FStep=Steps then break; { 4/10/99 - RSW, let caller invalidate last time }
//                           { to take care of problem with non-rectangular regions being painted correctly }
    UpdateControls;
    // 4/3/03 - ProcessMessages causes problems with themes so we do not call in this case
    if not fcUseThemes(Control) then Application.ProcessMessages;
    Sleep(Interval);
    if not fcUseThemes(Control) then Application.ProcessMessages;
  end;
end;
{
procedure fcAnimateControls(Control: TWinControl; ControlCanvas: TCanvas; AnimateList: TList; Interval: Integer; Steps: Integer; SetBoundsProc: TfcSetBoundsProc);
var FStep: Integer;
    Percent: Double;

  procedure UpdateControls;
  var i: Integer;
      Rgn, TmpRgn: HRGN;
      FirstRect, LastRect: TRect;
  begin
    with TfcGroupAnimateItem(AnimateList[0]).MainItem do FirstRect := fcUnionRect(CurRect, Control.BoundsRect);
    with TfcGroupAnimateItem(AnimateList[AnimateList.Count - 1]).MainItem do LastRect := fcUnionRect(CurRect, Control.BoundsRect);
    with fcUnionRect(FirstRect, LastRect) do Rgn := CreateRectRgn(Left, Top, Right, Bottom);

    for i := 0 to AnimateList.Count - 1 do with TfcGroupAnimateItem(AnimateList[i]), MainItem do
      begin
        Control.Update;
        with Control.BoundsRect do TmpRgn := CreateRectRgn(Left, Top, Right, Bottom);
        CombineRgn(Rgn, Rgn, TmpRgn, RGN_DIFF);
        DeleteObject(TmpRgn);
      end;

    ValidateRect(Control.Handle, nil);
    InvalidateRgn(Control.Handle, Rgn, True);
    Control.Update;
    DeleteObject(Rgn);

    for i := 0 to AnimateList.Count - 1 do with TfcGroupAnimateItem(AnimateList[i]) do if SecondItem <> nil then with SecondItem do
      Control.Update;
  end;

  procedure SetBounds(Item: TfcAnimateListItem);
  var R: TRect;
  begin
    with Item do
    begin
      CurRect := Control.BoundsRect;
      R := Rect(
        OrigRect.Left + Trunc((FinalRect.Left - OrigRect.Left) * Percent),
        OrigRect.Top + Trunc((FinalRect.Top - OrigRect.Top) * Percent),
        OrigRect.Right + Trunc((FinalRect.Right - OrigRect.Right) * Percent),
        OrigRect.Bottom + Trunc((FinalRect.Bottom - OrigRect.Bottom) * Percent)
      );
      if Assigned(SetBoundsProc) then SetBoundsProc(Control, R) else Control.BoundsRect := R;
    end;
  end;

  procedure Animate;
  var i: Integer;
  begin
    Percent := FStep / Steps;
    for i := 0 to AnimateList.Count - 1 do with TfcGroupAnimateItem(AnimateList[i]) do
    begin
      SetBounds(MainItem);
      if SecondItem <> nil then SetBounds(SecondItem);
    end;
  end;
begin
  if AnimateList.Count > 0 then for FStep := 1 to Steps do
  begin
    Animate;
    UpdateControls;
    Application.ProcessMessages;
    Sleep(Interval);
    Application.ProcessMessages;
  end;
end;
}
function fcWithInteger(Value: Integer): TfcInteger;
begin
  result.Value := Value;
end;

function fcCombineRect(r1, r2: TRect): TRect;
begin
  result := Rect(
    fcMin(r1.Left, r2.Left),
    fcMin(r1.Top, r2.Top),
    fcMax(r1.Right, r2.Right),
    fcMax(r1.Bottom, r2.Bottom)
  );
end;

procedure fcClipBitmapToRegion(Bitmap: TfcBitmap; Rgn: HRGN);
var RectRgn: HRGN;
begin
  RectRgn := CreateRectRgn(0, 0, Bitmap.Width, Bitmap.Height);
  try
    if CombineRgn(RectRgn, RectRgn, Rgn, RGN_DIFF) <> ERROR then
    begin
      Bitmap.Canvas.Brush.Color := Bitmap.TransparentColor;
      FillRgn(Bitmap.Canvas.Handle, RectRgn, Bitmap.Canvas.Brush.Handle);
    end;
  finally
    DeleteObject(RectRgn);
  end;
end;

function fcRGBToBGR(Color: TColor): TColor;
begin
  result := 0;
  result := result or ((Color and $00FF0000) shr 16);
  result := result or (Color and $0000FF00);
  result := result or ((Color and $000000FF) shl 16);
end;

function EnumChildProc(hwnd: HWND; lParam: LPARAM): Boolean; stdcall;
begin
  fcInvalidateChildren(hwnd);
  result := True;
end;

procedure fcInvalidateChildren(Control: HWND);
begin
  InvalidateRect(Control, nil, False);
  EnumChildWindows(Control, @EnumChildProc, 0);
end;

function fcGetWindowRect(Wnd: HWND): TRect;
begin
  GetWindowRect(Wnd, result);
end;

function fcUnionRect(R1, R2: TRect): TRect;
begin
  UnionRect(result, R1, R2);
end;

function fcIntersectRect(R1, R2: TRect): TRect;
begin
  IntersectRect(result, r1, r2);
end;

function fcRectEmpty(r: TRect): Boolean;
begin
  result := EqualRect(r, Rect(0, 0, 0, 0));
end;

function InvalidateOverlappedProc(Child: HWND; ARect: PRect): Boolean; stdcall;
begin
  if not fcRectEmpty(fcIntersectRect(ARect^, fcGetWindowRect(Child))) then
    fcInvalidateChildren(Child);
  result := True;
end;

procedure fcInvalidateOverlappedWindows(ParentHwnd: HWND; FirstChild: HWND);
var ControlRect: TRect;
begin
  GetWindowRect(FirstChild, ControlRect);
  EnumChildWindows(ParentHWND, @InvalidateOverlappedProc, Integer(@ControlRect));
end;

procedure fcParentInvalidate(Control: TControl; Erase: Boolean);
var r: TRect;
begin
  r := Control.BoundsRect;
  if Control.Parent <> nil then
    InvalidateRect(Control.Parent.Handle, @r, Erase);
end;

procedure fcPaintTo(Control: TWinControl; Canvas: TCanvas; X, Y: Integer);
{var OldTop: UINT;
    DC: HDC;}
var i: Integer;
begin
  SendMessage(Control.Handle, WM_ERASEBKGND, Canvas.Handle, 0);
  SendMessage(Control.Handle, WM_PAINT, Canvas.Handle, 0);

  for i := 0 to Control.ControlCount - 1 do if Control.Controls[i] is TWinControl then
    fcPaintTo(Control.Controls[i] as TWinControl, Canvas, Control.Controls[i].Left, Control.Controls[i].Top);  
{  OldTop := $FFFFFFFF;
  if not Control.Visible then
  begin
    OldTop := Control.Top;
    Control.Top := -Control.Height;
    Control.Visible := True;
  end;

  DC := GetWindowDC(Control.Handle);
  BitBlt(Canvas.Handle, 0, 0, Control.Width, Control.Height,
    DC, 0, 0, SRCCOPY);
  ReleaseDC(Control.Handle, DC);

  if OldTop <> $FFFFFFFF then
  begin
    Control.Top := OldTop;
    Control.Visible := False;
  end;}
end;

procedure fcBufferredAnimation(ControlCanvas: TCanvas; AnimateList: TList; Interval: Integer; Steps: Integer);
var FStep: Integer;
  procedure Animate;
  var i: Integer;
      Percent: Double;
  begin
    Percent := FStep / Steps;
    for i := 0 to AnimateList.Count - 1 do with TfcAnimateListItem(AnimateList[i]) do
    begin
      CurRect := Rect(
        OrigRect.Left + Trunc((FinalRect.Left - OrigRect.Left) * Percent),
        OrigRect.Top + Trunc((FinalRect.Top - OrigRect.Top) * Percent),
        OrigRect.Right + Trunc((FinalRect.Right - OrigRect.Right) * Percent),
        OrigRect.Bottom + Trunc((FinalRect.Bottom - OrigRect.Bottom) * Percent)
      );
      ControlCanvas.StretchDraw(CurRect, Bitmap);
    end;
  end;
var i: Integer;
begin
  for i := 0 to AnimateList.Count - 1 do
    with TfcAnimateListItem(AnimateList[i]) do
    begin
      Bitmap := TBitmap.Create;
      Bitmap.Width := Control.Width;
      Bitmap.Height := Control.Height;
      fcPaintTo(Control, Bitmap.Canvas, 0, 0);
//      SendMessage(Control.Handle, WM_PAINT, Bitmap.Canvas.Handle, 0);
//      fcPaintCanvas(Bitmap.Canvas, True);
    end;
  if AnimateList.Count > 0 then for FStep := 1 to Steps do
  begin
    Animate;
    Application.ProcessMessages;
    Sleep(Interval);
    Application.ProcessMessages;
  end;
  for i := 0 to AnimateList.Count - 1 do
    with TfcAnimateListItem(AnimateList[i]) do
      Bitmap.Free;
end;

function fcHighestRGBVal(Color: TColor): BYTE;
var Colors: TRGBQuad;
begin
  with Colors do
  begin
    fcColorToByteValues(Color, rgbReserved, rgbBlue, rgbGreen, rgbRed);
    result := rgbRed;
    if rgbBlue > result then result := rgbBlue;
    if rgbGreen > result then result := rgbGreen;
  end;
end;

const
  DSx =     $00660046;
  DSna =    $00220326;

procedure fcDrawMask(Canvas: TCanvas; ARect: TRect; Bitmap, Mask: TBitmap;
  Buffer: Boolean);
var oldBkColor, oldTextColor: COLORREF;
    dcCompat: HDC;
    pbmpSave: HBITMAP;
    ABitmap: TBitmap;
    UseCanvas: TCanvas;
    Offset: TPoint;
begin
  oldBkColor := SetBkColor(Canvas.Handle, RGB(255, 255, 255));
  oldTextColor := SetTextColor(Canvas.Handle, RGB(0, 0, 0));

  ABitmap := nil;

  if Buffer then
  begin
    ABitmap := TBitmap.Create;
    ABitmap.Width := fcRectWidth(ARect);
    ABitmap.Height := fcRectHeight(ARect);
    ABitmap.Canvas.CopyRect(Rect(0, 0, ABitmap.Width, ABitmap.Height), Canvas, ARect);
    UseCanvas := ABitmap.Canvas;
    Offset := Point(0, 0);
  end else begin
    UseCanvas := Canvas;
    Offset := ARect.TopLeft;
  end;

  dcCompat := CreateCompatibleDC(Canvas.Handle);
  pbmpSave := SelectObject(dcCompat, Bitmap.Handle);
  BitBlt(UseCanvas.Handle, Offset.x, Offset.y, fcRectWidth(ARect), fcRectHeight(ARect), dcCompat, 0, 0, DSx);
  SelectObject(dcCompat, Mask.Handle);
  BitBlt(UseCanvas.Handle, Offset.x, Offset.y, fcRectWidth(ARect), fcRectHeight(ARect), dcCompat, 0, 0, DSna);
  SelectObject(dcCompat, Bitmap.Handle);
  BitBlt(UseCanvas.Handle, Offset.x, Offset.y, fcRectWidth(ARect), fcRectHeight(ARect), dcCompat, 0, 0, DSx);
  SelectObject(dcCompat, pbmpSave);
  DeleteDC(dcCompat);

  if Buffer then
  begin
    Canvas.CopyRect(ARect, ABitmap.Canvas, Rect(0, 0, ABitmap.Width, ABitmap.Height));
    ABitmap.Free;
  end;

  SetBkColor(Canvas.Handle, oldBkColor);
  SetTextColor(Canvas.Handle, oldTextColor);
end;

function fcProportionalRect(OrigRect: TRect; Width, Height: Integer): TRect;
begin
  with OrigRect do
    if (Width / (Right - Left)) > (Height / (Bottom - Top)) then
      result := Rect(Left, Top, Left + fcRectWidth(OrigRect),
        Top + (Height * fcRectWidth(OrigRect) div Width))
    else result := Rect(Left, Top, Left + (Width *
      fcRectHeight(OrigRect) div Height), fcRectHeight(OrigRect));
end;

function fcProportionalCenterRect(OrigRect: TRect; Width, Height: Integer): TRect;
var aheightpad,awidthpad:extended;
begin
  with OrigRect do
    if (Width / (Right - Left)) > (Height / (Bottom - Top)) then begin
      aheightpad := (fcRectHeight(OrigRect)-(Height * (fcRectWidth(OrigRect) / Width))) / 2;
      result := Rect(Left, Top+Trunc(aheightpad), Left + fcRectWidth(OrigRect),
                Top + (Height * fcRectWidth(OrigRect) div Width)+Trunc(aheightpad));

    end
    else begin
      awidthpad := (fcRectWidth(OrigRect) - (Width * (fcRectHeight(OrigRect) / Height))) / 2;
      result := Rect(Left+Trunc(awidthpad), Top, Left + (Width *
                fcRectHeight(OrigRect) div Height)+Trunc(awidthpad), fcRectHeight(OrigRect));
    end;
end;

{ Return true if ComCtl is later than 4.70 }
function fcUpdatedComCtlVersion: boolean;
var dummy: DWORD;
    verInfoSize, verValueSize: DWORD;
    verInfo: Pointer;
    verValue: PVSFixedFileInfo;
    V1,V2: WORD;
begin
   verInfoSize:= GetFileVersionInfoSize('comctl32.dll', Dummy);
   if VerInfoSize = 0 then
   begin
      Dummy:= GetLastError;
      result:= True;
      exit;
   end;

   GetMem(VerInfo, VerInfoSize);
   GetFileVersionInfo('comctl32.dll', 0, VerInfoSize, VerInfo);
   VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
   with VerValue^ do begin
      V1:= dwFileVersionMS shr 16;
      V2:= dwFileVersionMS and $FFFF;
   end;
   result:= (v1>=4) and (v2>70);
   FreeMem(VerInfo, VerInfoSize);

end;

procedure fcPatternFill(Pattern: Pointer; SizeOfPat: Integer; Dst: Pointer; SizeOfDst: Integer);
var i: Integer;
begin
  for i := 0 to SizeOfDst div SizeOfPat do
    CopyMemory(Dst, Pattern, SizeOfPat);
  if SizeOfDst mod SizeOfPat > 0 then
    CopyMemory(Dst, Pattern, SizeOfDst mod SizeOfPat);
end;

type TMyControl = class(TWinControl);

procedure fcMakePagesResourceFriendly(PageControl: TPageControl);
var i, j: Integer;
begin
  with PageControl do
    for i := 0 to PageCount - 1 do
    begin
      if not Pages[i].Visible then
      begin
        for