fcshapebtn.pas

一套及时通讯的原码

    bsTrapezoid: begin
      result := 4;
      SetupPointList(Points, result);
      // Default Up, SetPointToOrientation adjusts for orientation
      Points[GetNum(0)] := Point(fcMin(Size.cy div 2, Size.cx div 2 div 2), 0);
      Points[GetNum(1)] := Point(Size.cx - fcMin(Size.cy div 2, Size.cx div 2 div 2), 0);
      Points[GetNum(2)] := Point(Size.cx, Size.cy);
      Points[GetNum(3)] := Point(0, Size.cy);
    end;
    bsArrow: begin
      result := 7;
      SetupPointList(Points, result);
      // Default Up, SetPointToOrientation adjusts for orientation
      Points[GetNum(0)] := Point(0, Size.cy div 3);
      Points[GetNum(1)] := Point(Size.cx div 2, 0);
      Points[GetNum(2)] := Point(Size.cx, Size.cy div 3);
      Points[GetNum(3)] := Point(Size.cx - Size.cx div 4, Size.cy div 3);
      Points[GetNum(4)] := Point(Size.cx - Size.cx div 4, Size.cy);
      Points[GetNum(5)] := Point(Size.cx div 4, Size.cy);
      Points[GetNum(6)] := Point(Size.cx div 4, Size.cy div 3);
    end;
    bsDiamond: begin
      result := 4;
      SetupPointList(Points, result);
      Points[GetNum(0)] := Point(Size.cx div 2, 0);
      Points[GetNum(1)] := Point(Size.cx, Size.cy div 2);
      Points[GetNum(2)] := Point(Size.cx div 2, Size.cy);
      Points[GetNum(3)] := Point(0, Size.cy div 2);
    end;
    bsRect: begin
      result := 4;
      SetupPointList(Points, result);
      Points[GetNum(0)] := Point(0, 0);
      Points[GetNum(1)] := Point(Size.cx, 0);
      Points[GetNum(2)] := Point(Size.cx, Size.cy);
      Points[GetNum(3)] := Point(0, Size.cy);
    end;
    bsStar: result := GetStarPoints(Points, Size);
    bsCustom: result := GetCustomPoints(Points, Size);
  end;
  if result > 0 then
  begin
    Points[result] := Points[0];
    inc(result);
    SetPointToOrientation(Points, result, Orientation, Size);
  end;
end;

function TfcCustomShapeBtn.CreateRegion(DoImplementation: Boolean; Down: Boolean): HRgn;
var DrawBitmap: TfcBitmap;
begin
  result := inherited CreateRegion(False, Down);
  if not DoImplementation or (result <> 0) then Exit;
  if (bsRect = Shape) and (parent<>nil) and
     fcIsClass(parent.classtype, 'TCustomGrid') then exit; // No shape region needed

  DrawBitmap := TfcBitmap.Create;
  try
    GetDrawBitmap(DrawBitmap, True, ShadeStyle, Down);
    result := fcRegionFromBitmap(DrawBitmap, UnusableColor);
  finally
    SaveRegion(result, Down);
    DrawBitmap.Free;
  end;
end;

function TfcCustomShapeBtn.IsMultipleRegions: Boolean;
begin
  result := False;
end;

function TfcCustomShapeBtn.StoreRegionData: Boolean;
begin
  result := False;
end;

function TfcCustomShapeBtn.CorrectedColor: TColor;
begin
  with fcGetColor(Color) do
  begin
    if not GoodVideoDriver then
    begin
      // 5/10/99 - PYW - Fixed Flat Style painting bug in High Color mode.
      if (r > 0) and (r mod 8 = 0) then dec(r);
      if (g > 0) and (g mod 8 = 0) then dec(g);
      if (b > 0) and (b mod 8 = 0) then dec(b);
    end;
    result := RGB(r, g, b);
  end;
end;

function TfcCustomShapeBtn.UnusableColor: TColor;
begin
  //11/28/00 - Fix bug when 3dColor is set to clRed
  if ColorToRGB(Color) <> DEFUNUSECOLOR then
    result := DEFUNUSECOLOR else result := DEFUNUSECOLOR2;
end;

type TBooleanArray = array[0..0] of Boolean;
     PBooleanArray = ^TBooleanArray;

procedure TfcCustomShapeBtn.AssignTo(Dest: TPersistent);
begin
  if Dest is TfcCustomShapeBtn then
    with Dest as TfcCustomShapeBtn do
  begin
    Orientation := self.Orientation;
    PointList := self.PointList;
    RoundRectBias := self.RoundRectBias;
    Shape := self.Shape;
  end;
  inherited;
end;

procedure TfcCustomShapeBtn.Draw3dLines(Bitmap: TfcBitmap; PointList: array of TPoint;
  NumPoints: Integer; TransColor: TColor);
  function MidPoint(p1, p2: TPoint): TPoint;
  begin
    result := Point(p1.x + (p2.x - p1.x) div 2, p1.y + (p2.y - p1.y) div 2);
  end;
var PolyRgn: HRGN;
    i: Integer;
    Difference: TSize;
    OutsideColor, InsideColor: TColor;
    Highlights: PBooleanArray;
    Offsets: PfcPolygonPoints;
    Focused: Integer;
    ACanvas: TCanvas;
    DownFlag:boolean;

    // 6/17/02
    Function DrawDarkBorder: boolean;
    begin
       result:= not (csPaintCopy in ControlState) and
               (self.Focused or Default);
    end;

begin
  DownFlag := Down and not (csPaintCopy in ControlState); // 6/17/02
  if ShowDownAsUp then begin
     DownFlag := False;
     if Clicked and MouseInControl(-1,-1,False) and not Selected then
        DownFlag := True;
  end;
  ACanvas := Bitmap.Canvas;
  if RoundShape then
  begin
//    fcOffsetBitmap(Bitmap, TransColor, Point(1, 1));
    inherited Draw3dLines(Bitmap, Bitmap, TransColor, DownFlag);
//    fcOffsetBitmap(Bitmap, TransColor, Point(-1, -1));
    Exit;
  end;

  PolyRgn := CreatePolygonRgn(PointList, NumPoints, WINDING);
  if PolyRgn = 0 then Exit;

  Highlights := AllocMem(SizeOf(Boolean) * NumPoints);
  Offsets := AllocMem(SizeOf(TPoint) * NumPoints);

  try
    for i := 0 to NumPoints - 2 do
    begin
      Highlights[i] := False;
      Difference := fcSize(Abs(PointList[i + 1].x - PointList[i].x),
                           Abs(PointList[i + 1].y - PointList[i].y));
      with MidPoint(PointList[i], PointList[i + 1]) do
        if (Difference.cx > Difference.cy) then
        begin
          if PtInRegion(PolyRgn, x, y + 1) then
          begin
            Highlights[i] := True;
            Offsets[i] := Point(0, 1);
          end else Offsets[i] := Point(0, -1);
        end else
        begin
          if PtInRegion(PolyRgn, x + 1, y) then
          begin
            Highlights[i] := True;
            Offsets[i] := Point(1, 0);
          end else Offsets[i] := Point(-1, 0);
        end;
      if (Difference.cx = 0) then
      begin
        Offsets[i] := Point(Offsets[i].x, -1);
        if PtInRegion(PolyRgn, PointList[i].x, fcMax(PointList[i].y, PointList[i + 1].y) + 1) then Offsets[i].y := 1;
      end else if (Difference.cy = 0) then
      begin
        Offsets[i] := Point(-1, Offsets[i].y);
        if PtInRegion(PolyRgn, fcMax(PointList[i].x, PointList[i + 1].x), PointList[i].y) then Offsets[i].x := 1;
      end;
    end;

    if DrawDarkBorder then Focused := 1 else Focused := 0;


    for i := 0 to NumPoints - 2 do
    begin
      if Highlights[i] xor DownFlag then InsideColor := ColorToRGB(ShadeColors.Btn3dLight)
      else InsideColor := ColorToRGB(ShadeColors.BtnShadow);

      ACanvas.Pen.Color := InsideColor;
      ACanvas.PolyLine([
        Point(PointList[i].x + Offsets[i].x * (1 + Focused), PointList[i].y + Offsets[i].y * (1 + Focused)),
        Point(PointList[i + 1].x + Offsets[i].x * (1 + Focused), PointList[i + 1].y + Offsets[i].y * (1 + Focused))
      ]);
    end;

    for i := 0 to NumPoints - 2 do
    begin
      if Highlights[i] xor DownFlag then OutsideColor := ColorToRGB(ShadeColors.BtnHighlight)
      else OutsideColor := ColorToRGB(ShadeColors.BtnBlack);

      ACanvas.Pen.Color := OutsideColor;
      ACanvas.Polyline([
        Point(PointList[i].x + Offsets[i].x * Focused, PointList[i].y + Offsets[i].y * Focused),
        Point(PointList[i + 1].x + Offsets[i].x * Focused, PointList[i + 1].y + Offsets[i].y * Focused)
      ]);
    end;

    if DrawDarkBorder then
      for i := 0 to NumPoints - 2 do
      begin
        ACanvas.Pen.Color := ShadeColors.BtnFocus;
        ACanvas.PolyLine([PointList[i], PointList[i + 1]]);
      end;
  finally
    DeleteObject(PolyRgn);
    FreeMem(Highlights);
    FreeMem(Offsets);
  end;
end;

function TfcCustomShapeBtn.RoundShape: Boolean;
begin
  result := Shape in [bsRoundRect, bsEllipse];
end;

procedure TfcCustomShapeBtn.DoComputeCanvasAttributes(ACanvas: TCanvas);
begin
  if Assigned(FOnComputeCanvasAttributes) then
     FOnComputeCanvasAttributes(Self, ACanvas);
end;

procedure TfcCustomShapeBtn.GetDrawBitmap(DrawBitmap: TfcBitmap; ForRegion: Boolean;
  ShadeStyle: TfcShadeStyle; Down: Boolean);
var PointList: PfcPolyGonPoints;
    NumPoints: Integer;
//    DitherBm: TBitmap;
    DoDraw3d: Boolean;
    OldBrush, ABrush: HBRUSH;
    {$ifdef fcUseThemeManager}
    Button: TThemedButton;
    Details: TThemedElementDetails;
    r: TRect;
    {$endif}
//    IsDefault: boolean;
begin
  DoDraw3d := True;
  //5/24/2000-PYW-Add check to not paint in 3D if control is disabled.
  case ShadeStyle of
    fbsFlat: DoDraw3d := (csDesigning in ComponentState) or (MouseInControl(-1, -1, False) and Enabled) or Down;
  end;

  ABrush := 0;
  OldBrush := 0;
  DrawBitmap.SetSize(Width, Height);

  //3/16/99 - PYW - Raises canvas draw error when anchors cause width or height to be <=0
  if (Width <=0) or (Height<=0) then exit;

  DrawBitmap.Canvas.Brush.Color := UnusableColor;
  DrawBitmap.Canvas.FillRect(Rect(0, 0, Width, Height));
  DrawBitmap.Canvas.Brush.Color := CorrectedColor;
//  DrawBitmap.Canvas.Brush.Color := clRed;
  DoComputeCanvasAttributes(DrawBitmap.Canvas);

  if DoDraw3d then DrawBitmap.Canvas.Pen.Color := ColorToRGB(DitherColor)
  else DrawBitmap.Canvas.Pen.Color := DrawBitmap.Canvas.Brush.Color;

  if Down and (DitherColor <> clNone) and (GroupIndex <> 0) then
  begin
    ABrush := fcGetDitherBrush;
    SetBkColor(DrawBitmap.Canvas.Handle, ColorToRGB(DitherColor));
    SetTextColor(DrawBitmap.Canvas.Handle, ColorToRGB(Color));
    OldBrush := SelectObject(DrawBitmap.Canvas.Handle, ABrush);
  end;

  try

    PointList := nil;
    if RoundShape then
    begin
      DrawBitmap.Canvas.Pen.Color := CorrectedColor;
      case Shape of
        bsRoundRect: DrawBitmap.Canvas.RoundRect(
          0, 0, Width - 1, Height - 1, RoundRectBias, RoundRectBias);
        bsEllipse: DrawBitmap.Canvas.Ellipse(
          0, 0, Width - 1, Height - 1);
      end;
      if not ForRegion and DoDraw3d then { 5/2/99 - RSW - Support flat for RoundShape }
         Draw3dLines(DrawBitmap, [Point(0, 0)], 0, UnusableColor);
    end else begin
      NumPoints := GetPolygonPoints(PointList);
      if PointList <> nil then Polygon(DrawBitmap.Canvas.Handle, PointList^, NumPoints);
      if not ForRegion and DoDraw3d and (PointList <> nil) then Draw3dLines(DrawBitmap, Slice(PointList^, NumPoints), NumPoints, UnusableColor);

      if (Shape in [bsRect]) and fcUseThemes(self) then
      begin
{         with LastDrawItemStruct do
         begin
           IsDefault := itemState and ODS_FOCUS <> 0;
         end;
}
         {$ifdef fcUseThemeManager}
         if not Enabled then
            Button := tbPushButtonDisabled
         else if Down then
            Button := tbPushButtonPressed
         else if MouseInControl(-1,-1, False) and not (csPaintCopy in ControlState) then
            Button := tbPushButtonHot
         else if Focused {or IsDefault } then
            Button := tbPushButtonDefaulted
         else
            Button := tbPushButtonNormal;

// 4/3/03 - Comment following code has it causes buttons in buttongroup to have bad canvas when transparent is true for the buttongroup
//        if (parent<>nil) and not fcIsClass(parent.classtype, 'TCustomGrid') then
//           ThemeServices.DrawParentBackground(Handle, DrawBitmap.Canvas.handle, nil, False);

        Details := ThemeServices.GetElementDetails(Button);
        r:= Rect(0, 0, Width-1, Height-1);
        ThemeServices.DrawElement(DrawBitmap.Canvas.Handle, Details, r);
        {$endif}
      end
      else if fcUseThemes(self) then
      begin
      end

    end;

    if OldBrush <> 0 then SelectObject(DrawBitmap.Canvas.Handle, OldBrush);
    if ABrush <> 0 then DeleteObject(ABrush);
  finally
    if not RoundShape then FreeMem(PointList);
  end;
end;

procedure TfcCustomShapeBtn.SizeToDefault;
begin
  if Width > Height then Height := Width else Width := Height;
end;

procedure TfcCustomShapeBtn.SetRoundRectBias(Value:Integer);
begin
  if Value <> FRoundRectBias then
  begin
    FRoundRectBias := Value;
    RecreateWnd;
  end;
end;

function TfcCustomShapeBtn.UseRegions: boolean;
begin
   result:= True;
end;

procedure TfcCustomShapeBtn.WndProc(var Message: TMessage);
begin
  inherited;
end;

{$R+}

end.