fccommon.pas

一套及时通讯的原码

    Result := ColorToRGB(Value);
    case Result of
      clNone: Result := CLR_NONE;
      clDefault: Result := CLR_DEFAULT;
    end;
  end;
var AMonoBitmap: TBitmap;
begin
  with ImageList do
  begin
    if HandleAllocated then
    begin
      if Enabled then
        if odd(x) then
          ImageList_DrawEx(Handle, Index, Canvas.Handle, X-1, Y, 0, 0, //ImageList.Width, ImageList.Height,
          GetRGBColor(TImageList(ImageList).BkColor), GetRGBColor(TImageList(ImageList).BlendColor), Style)
        else
          ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0,
          GetRGBColor(TImageList(ImageList).BkColor), GetRGBColor(TImageList(ImageList).BlendColor), Style)
      else
      begin
        AMonoBitmap := TBitmap.Create;
        with AMonoBitmap do
        begin
          Monochrome := True;
          Width := TImageList(ImageList).Width;
          Height := TImageList(ImageList).Height;
        end;

        { Store masked version of image temporarily in FBitmap }
        ImageList_DrawEx(Handle, Index, AMonoBitmap.Canvas.Handle, 0,0,0,0, 0,0,
          ILD_MASK);
        R := Rect(X, Y, X+TImageList(ImageList).Width, Y+TImageList(ImageList).Height);
        SrcDC := AMonoBitmap.Canvas.Handle;
        { Convert Black to clBtnHighlight }
        Canvas.Brush.Color := clBtnHighlight;
        DestDC := Canvas.Handle;
        Windows.SetTextColor(DestDC, clWhite);
        Windows.SetBkColor(DestDC, clBlack);
        BitBlt(DestDC, X+1, Y+1, TImageList(ImageList).Width, TImageList(ImageList).Height, SrcDC, 0, 0, ROP_DSPDxax);
        { Convert Black to clBtnShadow }
        Canvas.Brush.Color := clBtnShadow;
        DestDC := Canvas.Handle;
        Windows.SetTextColor(DestDC, clWhite);
        Windows.SetBkColor(DestDC, clBlack);
        BitBlt(DestDC, X, Y, TImageList(ImageList).Width, TImageList(ImageList).Height, SrcDC, 0, 0, ROP_DSPDxax);
        AMonoBitmap.Free;
      end;
    end;
  end;
end;

procedure fcIncSize(var Size: TSize; Amount: Integer);
begin
  inc(Size.cx, Amount);
  inc(Size.cy, Amount); 
end;

function fcGetHintWindow: THintWindow;
var i: Integer;
begin
  result := nil;
  for i := 0 to Application.ComponentCount - 1 do
    if Application.Components[i] is THintWindow then
    begin
      result := Application.Components[i] as THintWindow;
      Break;
    end;
end;

function fcMessage(Msg: Cardinal; wParam: WPARAM; lParam: LPARAM; MsgRslt: Cardinal): TMessage;
begin
  result.Msg := Msg;
  result.wParam := wParam;
  result.lParam := lParam;
  result.Result := MsgRslt;
end;

function fcGetFontType(AFontType: Integer): TfcFontType;
begin
  if AFontType = DEVICE_FONTTYPE then result := ftPrinter
  else if AFontType and TRUETYPE_FONTTYPE <> 0 then result := ftTrueType
  else result := ftOther;
end;

function fcFontCallBack(lpelf: PEnumLogFontEx; lpntm: PNewTextMetricEx; FontType: Integer;
  FontIcon: PfcFontType): Integer; stdcall;
begin
  result := 0;
  FontIcon^ := fcGetFontType(FontType);
end;

function fcGetFontIcon(FaceName: string): TfcFontType;
var lf: TLogFont;
begin
  FillChar(lf, SizeOf(lf), 0);
  StrLCopy(lf.lfFaceName, PChar(FaceName), 32);
  EnumFontFamiliesEx(Printers.Printer.Handle, lf, @fcFontCallback, Integer(@result), 0);
end;

function fcGetStrProp(Component: TPersistent; PropName: string): string;
var PropInfo: PPropInfo;
begin
  result := '';
  PropInfo := GetPropInfo(Component.ClassInfo, PropName);
  if PropInfo <> nil then result := GetStrProp(Component, PropInfo);
end;

function fcGetOrdProp(Component: TPersistent; PropName: string): Integer;
var PropInfo: PPropInfo;
begin
  result := 0;
  PropInfo := GetPropInfo(Component.ClassInfo, PropName);
  if PropInfo <> nil then result := GetOrdProp(Component, PropInfo);
end;

procedure fcSetStrProp(Component: TPersistent; PropName: string; Value: string);
var PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(Component.ClassInfo, PropName);
  if PropInfo <> nil then SetStrProp(Component, PropInfo, Value);
end;

procedure fcSetOrdProp(Component: TPersistent; PropName: string; Value: Integer);
var PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(Component.ClassInfo, PropName);
  if PropInfo <> nil then SetOrdProp(Component, PropInfo, Value);
end;

procedure fcGetBooleanProps(Component: TPersistent; List: TStrings);
var PropList: PPropList;
    i: Integer;
    PropCount: Integer;
begin
  PropCount := GetTypeData(Component.ClassInfo).PropCount;
  GetMem(PropList, PropCount * Sizeof(Pointer));
  try
    GetPropInfos(Component.ClassInfo, PropList);
    for i := 0 to PropCount - 1 do
      if (PropList[i]^.PropType^.Kind = tkEnumeration) and
         (PropList[i]^.PropType^.Name = 'Boolean') then
        List.Add(PropList[i].Name);
  finally
    FreeMem(PropList);
  end;
end;

function fcLogFont: TLogFont;
begin
  with result do
  begin
    FillChar(result, SizeOf(result), 0);
    lfCharSet := DEFAULT_CHARSET;
    lfFaceName := '';
    lfPitchAndFamily := 0;
  end;
end;

procedure fcShowHint(Hint: string; Coord: TPoint);
var r: TRect;
begin
  with fcGetHintWindow do
  begin
    r := CalcHintRect(Screen.Width - Coord.x, Hint, nil);
    OffsetRect(r, Coord.x, Coord.y + 20);
    ActivateHint(r, Hint);
  end;
end;

procedure fcPaintGraphic(AGraphic: TGraphic; Modal: Boolean);
var ASize: TSize;
    Form: TForm;
begin
  ASize := fcSize(AGraphic.Width, AGraphic.Height);
  Form := TForm.Create(Application);
  with Form do
  begin
    Width := ASize.cx;
    Height := ASize.cy;
    Left := (Screen.Width - Width) div 2;
    Top := (Screen.Height - Height) div 2;
    with TImage.Create(Form) do
    begin
      Parent := Form;
      Align := alClient;
      Picture.Bitmap.Width := Width;
      Picture.Bitmap.Height := Height;
      Picture.Bitmap.Canvas.Draw(0, 0, AGraphic);
    end;
    if Modal then ShowModal else Show;
  end;
end;

// The following three functions are handy debugging functions to
// display a Canvas or Region.  Great for bitmaps and stuff. -ksw

procedure fcPaintCanvas(ACanvas: TCanvas; Modal: Boolean);
const SCALE = 2;
var ASize: TSize;
    Form: TForm;
begin
  ASize := fcSize(fcRectWidth(ACanvas.ClipRect), fcRectHeight(ACanvas.ClipRect));
  Form := TForm.Create(Application);
  with Form do
  begin
    Width := ASize.cx * SCALE;
    Height := ASize.cy * SCALE;
    Left := (Screen.Width - Width) div 2;
    Top := (Screen.Height - Height) div 2;
    with TImage.Create(Form) do
    begin
      Parent := Form;
      Align := alClient;
      Picture.Bitmap.Width := Width;
      Picture.Bitmap.Height := Height;
      Picture.Bitmap.Canvas.CopyRect(Rect(0, 0, ASize.cx, ASize.cy),
        ACanvas, Rect(0, 0, ASize.cx, ASize.cy));
    end;
    if Modal then ShowModal else Show;
  end;
end;

procedure fcPaintDC(DC: HDC; Modal: Boolean);
var ACanvas: TCanvas;
begin
  ACanvas := TCanvas.Create;
  ACanvas.Handle := DC;
  fcPaintCanvas(ACanvas, Modal);
  ACanvas.Handle := 0;
  ACanvas.Free;
end;

procedure fcPaintRegion(Rgn: HRGN; DoOffset: Boolean; ShowModal: Boolean);
const SCALE = 2;
var RgnData: PRgnData;
    Size: Integer;
    Offset: TPoint;
    RgnSize: TSize;
    i: Integer;
    ACanvas: TCanvas;
    r: TRect;
    Form: TForm;
begin
  Size := GetRegionData(Rgn, 0, nil);
  if Size = 0 then Exit;
  GetMem(RgnData, Size);
  try
    GetRegionData(Rgn, Size, RgnData);
    Offset := Point(0, 0);
    if DoOffset then Offset := RgnData^.rdh.rcBound.TopLeft;
    with RgnData^.rdh.rcBound.BottomRight do
    RgnSize := fcSize(x - Offset.x, y - Offset.y);

    Form := TForm.Create(Application);
    with Form do
    begin
      Width := RgnSize.cx * SCALE;
      Height := RgnSize.cy * SCALE;
      Left := (Screen.Width - Width) div 2;
      Top := (Screen.Height - Height) div 2;
      with TImage.Create(Form) do
      begin
        Parent := Form;
        Align := alClient;
        Picture.Bitmap.Width := Width;
        Picture.Bitmap.Height := Height;
        ACanvas := Picture.Bitmap.Canvas;
        ACanvas.Brush.Color := clRed;
      end;
    end;

    for i := 0 to RgnData^.rdh.nCount - 1 do
    begin
      r := PRect(Integer(@RgnData^.Buffer) + i * SizeOf(TRect))^;
      OffsetRect(r, -Offset.x, -Offset.y);
      ACanvas.FillRect(r);
    end;
    Form.ShowModal;
    Form.Free;
  finally
    FreeMem(RgnData);
  end;
end;

procedure fcGetChildRegions(Control: TWinControl; Transparent: Boolean; Rgn: HRGN; Offset: TPoint;
  Flags: Integer);
var TmpRgn: HRGN;
    i: Integer;
    r: TRect;
begin
  for i := 0 to Control.ControlCount - 1 do
  begin
    if Boolean(fcGetOrdProp(Control.Controls[i], 'Transparent')) then Continue;
//    RgnFlag := RGN_OR;
    if (Control.Controls[i] is TWinControl) then
    begin
      GetWindowRect(TWinControl(Control.Controls[i]).Handle, r);
      with Control.ClientToScreen(Point(0, 0)) do OffsetRect(r, -x, -y);
    end else begin
       r := Control.Controls[i].BoundsRect;
       if r.Right>Control.Width then r.Right:= Control.Width; { 5/2/99 - Limit to parent's boundaries }
       if r.Bottom>Control.Height then r.Bottom:= Control.Height
    end;

    OffsetRect(r, Offset.x, Offset.y);
    with r do TmpRgn := CreateRectRgn(Left, Top, Right, Bottom);
    CombineRgn(Rgn, Rgn, TmpRgn, Flags);
    DeleteObject(TmpRgn);

//    fcGetChildRegions(TWinControl(Control.Controls[i]), True, Rgn);
  end;
end;

// Changes the size and position of an array of controls from a
// beginning rect to an ending rect and animates the resizing/positioning.
//
// AnimateList - A TList of TAnimateListItem of each control to be
//               resized.  Each item contains an item consisting of
//               Control, OrigRect, and FinalRect; all of which must
//               be initialized to proper values.
//
// Interval    - The amount of time (in milliseconds) to pause between
//               each step of the resizing (length of each frame).
//
// Steps:      - The number of individual frames that the animation
//               will take.
//
// - ksw (12/10/98)

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;
  begin
    Rgn := CreateRectRgn(0,0,0,0);
    for i := 0 to AnimateList.Count - 1 do with TfcGroupAnimateItem(AnimateList[i]), MainItem do
      begin
        Control.Update;
        with fcUnionRect(CurRect, Control.BoundsRect) do TmpRgn := CreateRectRgn(Left, Top, Right, Bottom);
        CombineRgn(Rgn, Rgn, TmpRgn, RGN_OR);
        DeleteObject(TmpRgn);
      end;
    for i := 0 to AnimateList.Count - 1 do with TfcGroupAnimateItem(AnimateList[i]), MainItem do
    begin
      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 UpdateControls;
  var i: Integer;
      r: TRect;
  begin
    for i := 0 to AnimateList.Count - 1 do with TfcGroupAnimateItem(AnimateList[i]) do
      if SecondItem <> nil then
      begin
        r := SecondItem.Control.BoundsRect;
        ValidateRect(SecondItem.Control.Parent.Handle, @r);
      end;
    for i := 0 to AnimateList.Count - 1 do with TfcGroupAnimateItem(AnimateList[i]) do
    begin
      MainItem.Control.Invalidate;
      MainItem.Control.Update;
      if SecondItem <> nil then
      begin
        InvalidateRect(SecondItem.Control.Handle, nil, True);
        { RSW - 4/15/99 - Only invalidate portion of rectangle }
        if (SecondItem.Control.Top = SecondItem.CurRect.Top) and
           (SecondItem.Control.Left = SecondItem.CurRect.Left) {and
           ((SecondItem.Control.Height <= SecondItem.Currect.Bottom-SecondItem.Currect.Top) or
            (SecondItem.Control.Width <= SecondItem.Currect.Right-SecondItem.Currect.Left))}
           then
        begin
           r:= SecondItem.Currect;
           ValidateRect(SecondItem.Control.Parent.Handle, @r);
           SecondItem.Control.Update;
        end;
      end;
    end;
  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),