rm_tb97ctls.pas

中小企业管理系统------ ERP系统原代码

              else
                GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp,
                  SourceRect.TopLeft, IRectA.BottomRight, [-1]);
            end
            else
              MonoBmp.Canvas.CopyRect (IRectA, OriginalMaskBmp.Canvas, SourceRect);
            with MonoBmp do begin
              Width := Width + AddPixels;
              Height := Height + AddPixels;
              { Set the additional bottom and right row on disabled glyph
                masks to white so that it always shines through, since the
                bottom and right row on TmpImage was left uninitialized }
              Canvas.Pen.Color := clWhite;
              Canvas.PolyLine ([Point(0, Height-1), Point(Width-1, Height-1),
                Point(Width-1, -1)]);
            end;

            FIndexs[B, State] := FGlyphList[B].Add(TmpImage, MonoBmp);
          end
        else begin
          { Create a disabled version }
          if FOldDisabledStyle then begin
            { "Old" TSpeedButton style }
            if FImageList = nil then begin
              if not UsesMask then begin
                if IsHighColorDIB then
                  GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp,
                    SourceRect.TopLeft, IRectA.BottomRight, [clBlack])
                else begin
                  with MonoBmp do begin
                    Assign (DDB);  { must be a DDB for this to work right }
                    Canvas.Brush.Color := clBlack;
                    Monochrome := True;
                  end;
                end;
              end
              else begin
                MonoBmp.Assign (DDB);  { must be a DDB for this to work right }
                with TBitmap.Create do
                  try
                    Monochrome := True;
                    Width := OriginalMaskBmp.Width;
                    Height := OriginalMaskBmp.Height;
                    R := Rect(0, 0, Width, Height);
                    Canvas.CopyRect (R, OriginalMaskBmp.Canvas, R);
                    DC := Canvas.Handle;
                    with MonoBmp.Canvas do begin
                      BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
                        SourceRect.Left, SourceRect.Top, ROP_DSna);
                      BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
                        SourceRect.Left, SourceRect.Top, SRCPAINT);
                    end;
                  finally
                    Free;
                  end;
                MonoBmp.Canvas.Brush.Color := clBlack;
                MonoBmp.Monochrome := True;
              end
            end
            else begin
              with MonoBmp do begin
                Width := IWidthA;
                Height := IHeightA;
                Canvas.Brush.Color := clWhite;
                Canvas.FillRect (IRectA);
                ImageList_Draw (FImageList.Handle, FImageIndex, Canvas.Handle,
                  0, 0, ILD_TRANSPARENT);
                Canvas.Brush.Color := clBlack;
                Monochrome := True;
              end;
            end;
          end
          else begin
            { The new Office 97 / MFC look }
            if not UsesMask and (FImageList = nil) then begin
              with TmpImage.Canvas do begin
                if not IsHighColorDIB then
                  GenerateMaskBitmap (MonoBmp, DDB, IRectA.TopLeft,
                    IRectA.BottomRight, [FTransparentColor, clWhite, clSilver])
                else
                  GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp,
                    SourceRect.TopLeft, IRectA.BottomRight, [-1, clWhite, clSilver]);
              end;
            end
            else begin
              { Generate the mask in MonoBmp. Make clWhite and clSilver transparent. }
              if not IsHighColorDIB then
                GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft,
                  IRectA.BottomRight, [clWhite, clSilver])
              else
                GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp, SourceRect.TopLeft,
                  IRectA.BottomRight, [clWhite, clSilver]);
              if FImageList = nil then
                UseMaskBmp := OriginalMaskBmp
              else
                UseMaskBmp := MaskBmp;
              { and all the white colors in UseMaskBmp }
              with TBitmap.Create do
                try
                  Monochrome := True;
                  Width := UseMaskBmp.Width;
                  Height := UseMaskBmp.Height;
                  R := Rect(0, 0, Width, Height);
                  Canvas.CopyRect (R, UseMaskBmp.Canvas, R);
                  DC := Canvas.Handle;
                  with MonoBmp.Canvas do begin
                    BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
                      SourceRect.Left, SourceRect.Top, ROP_DSna);
                    BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
                      SourceRect.Left, SourceRect.Top, SRCPAINT);
                  end;
                finally
                  Free;
                end;
            end;
          end;

          with TmpImage.Canvas do begin
            Brush.Color := clBtnFace;
            FillRect (IRect);
            Brush.Color := clBtnHighlight;
            DC := Handle;
            SetTextColor (DC, clBlack);
            SetBkColor (DC, clWhite);
            BitBlt (DC, 1, 1, IWidthA, IHeightA,
              MonoBmp.Canvas.Handle, 0, 0, ROPs[FOldDisabledStyle]);
            Brush.Color := clBtnShadow;
            DC := Handle;
            SetTextColor (DC, clBlack);
            SetBkColor (DC, clWhite);
            BitBlt (DC, 0, 0, IWidthA, IHeightA,
              MonoBmp.Canvas.Handle, 0, 0, ROPs[FOldDisabledStyle]);
          end;

          FIndexs[B, State] := FGlyphList[B].AddMasked(TmpImage, clBtnFace);
        end;
      finally
        DDB.Free;
        MonoBmp.Free;
      end;
    end;
  finally
    MaskBmp.Free;
    TmpImage.Free;
    OriginalMaskBmp.Free;
    OriginalBmp.Free;
  end;
  Result.B := B;
  Result.I := FIndexs[B, State];
  { Note: Due to a bug in graphics.pas, Delphi 2's VCL crashes if Dormant is
    called on an empty bitmap, so to prevent this it must check Width/Height
    first }
  if {$IFNDEF TB97D3} (FOriginal.Width <> 0) and (FOriginal.Height <> 0) and {$ENDIF}
     FCallDormant then
    FOriginal.Dormant;
  {$IFNDEF TB97D3} if (FOriginalMask.Width <> 0) and (FOriginalMask.Height <> 0) then {$ENDIF}
    FOriginalMask.Dormant;
end;

procedure TButtonGlyph.DrawButtonGlyph (Canvas: TCanvas; const GlyphPos: TPoint;
  State: TButtonState97);
var
  Index: TBoolInt;
begin
  Index := CreateButtonGlyph(State);
  if Index.I <> -1 then
    ImageList_DrawEx (FGlyphList[Index.B].Handle, Index.I, Canvas.Handle,
      GlyphPos.X, GlyphPos.Y, 0, 0, CLR_NONE, CLR_NONE, ILD_TRANSPARENT);
end;

procedure TButtonGlyph.DrawButtonText (Canvas: TCanvas; const Caption: string;
  TextBounds: TRect; WordWrap: Boolean; Alignment: TAlignment;
  State: TButtonState97);
const
  AlignmentFlags: array[TAlignment] of UINT = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  Format: UINT;
begin
  Format := DT_VCENTER or AlignmentFlags[Alignment];
  if not WordWrap then
    Format := Format or DT_SINGLELINE
  else
    Format := Format or DT_WORDBREAK;
  with Canvas do begin
    Brush.Style := bsClear;
    if State = bsDisabled then begin
      OffsetRect (TextBounds, 1, 1);
      Font.Color := clBtnHighlight;
      DrawText (Handle, PChar(Caption), Length(Caption), TextBounds, Format);
      OffsetRect (TextBounds, -1, -1);
      Font.Color := clBtnShadow;
      DrawText (Handle, PChar(Caption), Length(Caption), TextBounds, Format);
    end
    else
      DrawText (Handle, PChar(Caption), Length(Caption), TextBounds, Format);
  end;
end;

procedure TButtonGlyph.DrawButtonDropArrow (Canvas: TCanvas;
  const X, Y, AWidth: Integer; State: TButtonState97);
var
  X2: Integer;
begin
  with Canvas do begin
    X2 := X + AWidth div 2;
    if State = bsDisabled then begin
      Pen.Color := clBtnHighlight;
      Brush.Color := clBtnHighlight;
      Polygon ([Point(X2-1, Y+1), Point(X2+3, Y+1), Point(X2+1, Y+3)]);
      Pen.Color := clBtnShadow;
      Brush.Color := clBtnShadow;
      Polygon ([Point(X2-2, Y), Point(X2+2, Y), Point(X2, Y+2)]);
    end
    else begin
      Pen.Color := Font.Color;
      Brush.Color := Font.Color;
      Polygon ([Point(X2-2, Y), Point(X2+2, Y), Point(X2, Y+2)]);
    end;
  end;
end;

procedure TButtonGlyph.CalcButtonLayout (Canvas: TCanvas; const Client: TRect;
  const Offset: TPoint; DrawGlyph, DrawCaption: Boolean; const Caption: string;
  WordWrap: Boolean; Layout: TButtonLayout; Margin, Spacing: Integer;
  DropArrow: Boolean; DropArrowWidth: Integer; var GlyphPos, ArrowPos: TPoint;
  var TextBounds: TRect);
var
  TextPos: TPoint;
  ClientSize, GlyphSize, TextSize, ArrowSize: TPoint;
  HasGlyph: Boolean;
  TotalSize: TPoint;
  Format: UINT;
  Margin1, Spacing1: Integer;
  LayoutLeftOrRight: Boolean;
begin
  { calculate the item sizes }
  ClientSize := Point(Client.Right-Client.Left, Client.Bottom-Client.Top);

  GlyphSize.X := 0;
  GlyphSize.Y := 0;
  if DrawGlyph then begin
    if FImageList = nil then begin
      if FOriginal <> nil then begin
        GlyphSize.X := FOriginal.Width div FNumGlyphs;
        GlyphSize.Y := FOriginal.Height;
      end;
    end
    else begin
      GlyphSize.X := TCustomImageListAccess(FImageList).Width;
      GlyphSize.Y := TCustomImageListAccess(FImageList).Height;
    end;
  end;
  HasGlyph := (GlyphSize.X <> 0) and (GlyphSize.Y <> 0);

  if DropArrow then begin
    ArrowSize.X := DropArrowWidth;
    ArrowSize.Y := 3;
  end
  else begin
    ArrowSize.X := 0;
    ArrowSize.Y := 0;
  end;

  LayoutLeftOrRight := Layout in [blGlyphLeft, blGlyphRight];
  if not LayoutLeftOrRight and not HasGlyph then begin
    Layout := blGlyphLeft;
    LayoutLeftOrRight := True;
  end;

  if DrawCaption and (Caption <> '') then begin
    TextBounds := Rect(0, 0, Client.Right-Client.Left, 0);
    if LayoutLeftOrRight then
      Dec (TextBounds.Right, ArrowSize.X);
    Format := DT_CALCRECT;
    if WordWrap then begin
      Format := Format or DT_WORDBREAK;
      Margin1 := 4;
      if LayoutLeftOrRight and HasGlyph then begin
        if Spacing = -1 then
          Spacing1 := 4
        else
          Spacing1 := Spacing;
        Dec (TextBounds.Right, GlyphSize.X + Spacing1);
        if Margin <> -1 then
          Margin1 := Margin
        else
        if Spacing <> -1 then
          Margin1 := Spacing;
      end;
      Dec (TextBounds.Right, Margin1 * 2);
    end;
    DrawText (Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, Format);
    TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
      TextBounds.Top);
  end
  else begin
    TextBounds := Rect(0, 0, 0, 0);
    TextSize := Point(0,0);
  end;

  { If the layout has the glyph on the right or the left, then both the
    text and the glyph are centered vertically.  If the glyph is on the top
    or the bottom, then both the text and the glyph are centered horizontally.}
  if LayoutLeftOrRight then begin
    GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
    TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  end
  else begin
    GlyphPos.X := (ClientSize.X - GlyphSize.X - ArrowSize.X + 1) div 2;
    TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
    if not HasGlyph then
      ArrowPos.X := TextPos.X + TextSize.X
    else
      ArrowPos.X := GlyphPos.X + GlyphSize.X;
  end;

  { if there is no text or no bitmap, then Spacing is irrelevant }
  if (TextSize.X = 0) or (TextSize.Y = 0) or not HasGlyph then
    Spacing := 0;

  { adjust Margin and Spacing }
  if Margin = -1 then begin
    if Spacing = -1 then begin
      TotalSize := Point(GlyphSize.X + TextSize.X + ArrowSize.X,
        GlyphSize.Y + TextSize.Y);
      if LayoutLeftOrRight then
        Margin := (ClientSize.X - TotalSize.X) div 3
      else
        Margin := (ClientSize.Y - TotalSize.Y) div 3;
      Spacing := Margin;
    end
    else begin
      TotalSize := Point(GlyphSize.X + Spacing + TextSize.X + ArrowSize.X,
        GlyphSize.Y + Spacing + TextSize.Y);
      if LayoutLeftOrRight then
        Margin := (ClientSize.X - TotalSize.X + 1) div 2
      else
        Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
    end;
  end
  else begin
    if Spacing = -1 then begin
      TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X + ArrowSize.X),
        ClientSize.Y - (Margin + GlyphSize.Y));
      if LayoutLeftOrRight then
        Spacing := (TotalSize.X - TextSize.X) div 2
      else
        Spacing := (TotalSize.Y - TextSize.Y) div 2;
    end;
  end;

  case Layout of
    blGlyphLeft: begin
        GlyphPos.X := Margin;
        TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
        ArrowPos.X := TextPos.X + TextSize.X;
      end;
    blGlyphRight: begin
        ArrowPos.X := ClientSize.X - Margin - ArrowSize.X;
        GlyphPos.X := ArrowPos.X - GlyphSize.X;
        TextPos.X := GlyphPos.X - Spacing - TextSize.X;
      end;
    blGlyphTop: begin
        GlyphPos.Y := Margin;
        TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
      end;
    blGlyphBottom: begin
        GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
        TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
      end;
  end;
  Inc (ArrowPos.X);
  if not HasGlyph then
    ArrowPos.Y := TextPos.Y + (TextSize.Y - ArrowSize.Y) div 2
  else
    ArrowPos.Y := GlyphPos.Y + (GlyphSize.Y - ArrowSize.Y) div 2;

  { fixup the result variables }
  with GlyphPos do begin
    Inc (X, Client.Left + Offset.X);
    Inc (Y, Client.Top + Offset.Y);
  end;
  with ArrowPos do begin