tb97ctls.pas

企业智能(ERP)管理系统

  private
    GlyphLists: TList;
  public
    constructor Create;
    destructor Destroy; override;
    function GetList(AWidth, AHeight: Integer): TGlyphList;
    procedure ReturnList(List: TGlyphList);
    function Empty: Boolean;
  end;

  TBoolInt = record
    B: Boolean;
    I: Integer;
  end;

  TCustomImageListAccess = class(TCustomImageList);

  TButtonGlyph = class
  private
    FOriginal, FOriginalMask: TBitmap;
    FCallDormant: Boolean;
    FGlyphList: array[Boolean] of TGlyphList;
    FImageIndex: Integer;
    FImageList: TCustomImageList;
    FImageChangeLink: TChangeLink;
    FIndexs: array[Boolean, TButtonState97] of Integer;
    FTransparentColor: TColor;
    FNumGlyphs: TNumGlyphs97;
    FOnChange: TNotifyEvent;
    FOldDisabledStyle: Boolean;
    procedure GlyphChanged (Sender: TObject);
    procedure SetGlyph (Value: TBitmap);
    procedure SetGlyphMask (Value: TBitmap);
    procedure SetNumGlyphs (Value: TNumGlyphs97);
    procedure UpdateNumGlyphs;
    procedure Invalidate;
    function CreateButtonGlyph (State: TButtonState97): TBoolInt;
    procedure DrawButtonGlyph (Canvas: TCanvas; const GlyphPos: TPoint;
      State: TButtonState97);
    procedure DrawButtonText (Canvas: TCanvas;
      const Caption: string; TextBounds: TRect;
      WordWrap: Boolean; Alignment: TAlignment; State: TButtonState97);
    procedure CalcButtonLayout (Canvas: TCanvas; const Client: TRect;
      const Offset: TPoint; DrawGlyph, DrawCaption: Boolean;
      const Caption: string; WordWrap: Boolean;
      Layout: TButtonLayout; Margin, Spacing: Integer; DropArrow: Boolean;
      var GlyphPos, ArrowPos: TPoint; var TextBounds: TRect);
  public
    constructor Create;
    destructor Destroy; override;
    { returns the text rectangle }
    function Draw (Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
      DrawGlyph, DrawCaption: Boolean; const Caption: string; WordWrap: Boolean;
      Alignment: TAlignment; Layout: TButtonLayout; Margin, Spacing: Integer;
      DropArrow: Boolean; State: TButtonState97): TRect;
    procedure DrawButtonDropArrow (Canvas: TCanvas;
      const X, Y: Integer; State: TButtonState97);
    property Glyph: TBitmap read FOriginal write SetGlyph;
    property GlyphMask: TBitmap read FOriginalMask write SetGlyphMask;
    property NumGlyphs: TNumGlyphs97 read FNumGlyphs write SetNumGlyphs;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;


{ TGlyphList }

constructor TGlyphList.CreateSize(AWidth, AHeight: Integer);
begin
  inherited CreateSize (AWidth, AHeight);
  Used := TBits.Create;
end;

destructor TGlyphList.Destroy;
begin
  Used.Free;
  inherited;
end;

function TGlyphList.AllocateIndex: Integer;
begin
  Result := Used.OpenBit;
  if Result >= Used.Size then
  begin
    Result := inherited Add(nil, nil);
    Used.Size := Result + 1;
  end;
  Used[Result] := True;
end;

function TGlyphList.Add (Image, Mask: TBitmap): Integer;
begin
  Result := AllocateIndex;
  Replace (Result, Image, Mask);
  Inc (FCount);
end;

function TGlyphList.AddMasked (Image: TBitmap; MaskColor: TColor): Integer;
  procedure BugfreeReplaceMasked (Index: Integer; NewImage: TBitmap; MaskColor: TColor);
    procedure CheckImage (Image: TGraphic);
    begin
      if Image = nil then Exit;
      if (Image.Height < Height) or (Image.Width < Width) then
        raise EInvalidOperation.Create({$IFNDEF TB97D3}LoadStr{$ENDIF}(SInvalidImageSize));
    end;
  var
    TempIndex: Integer;
    Image, Mask: TBitmap;
  begin
    if HandleAllocated then begin
      CheckImage(NewImage);
      TempIndex := inherited AddMasked(NewImage, MaskColor);
      if TempIndex <> -1 then
        try
          Image := nil;
          Mask := nil;
          try
            Image := TBitmap.Create;
            Image.Height := Height;
            Image.Width := Width;
            Mask := TBitmap.Create;
            Mask.Monochrome := True;
            { ^ Prevents the "invisible glyph" problem when used with certain
                color schemes. (Fixed in Delphi 3.01) }
            Mask.Height := Height;
            Mask.Width := Width;
            ImageList_Draw (Handle, TempIndex, Image.Canvas.Handle, 0, 0, ILD_NORMAL);
            ImageList_Draw (Handle, TempIndex, Mask.Canvas.Handle, 0, 0, ILD_MASK);
            if not ImageList_Replace(Handle, Index, Image.Handle, Mask.Handle) then
              raise EInvalidOperation.Create({$IFNDEF TB97D3}LoadStr{$ENDIF}(SReplaceImage));
          finally
            Image.Free;
            Mask.Free;
          end;
        finally
          inherited Delete(TempIndex);
        end
      else
        raise EInvalidOperation.Create({$IFNDEF TB97D3}LoadStr{$ENDIF}(SReplaceImage));
    end;
    Change;
  end;
begin
  Result := AllocateIndex;
  { This works two very serious bugs in the Delphi 2/BCB and Delphi 3
    implementations of the ReplaceMasked method. In the Delphi 2 and BCB
    versions of the ReplaceMasked method, it incorrectly uses ILD_NORMAL as
    the last parameter for the second ImageList_Draw call, in effect causing
    all white colors to be considered transparent also. And in the Delphi 2/3
    and BCB versions it doesn't set Monochrome to True on the Mask bitmap,
    causing the bitmaps to be invisible on certain color schemes. }
  BugfreeReplaceMasked (Result, Image, MaskColor);
  Inc (FCount);
end;

procedure TGlyphList.Delete (Index: Integer);
begin
  if Used[Index] then begin
    Dec(FCount);
    Used[Index] := False;
  end;
end;

{ TGlyphCache }

constructor TGlyphCache.Create;
begin
  inherited;
  GlyphLists := TList.Create;
end;

destructor TGlyphCache.Destroy;
begin
  GlyphLists.Free;
  inherited;
end;

function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
var
  I: Integer;
begin
  for I := GlyphLists.Count - 1 downto 0 do begin
    Result := GlyphLists[I];
    with Result do
      if (AWidth = Width) and (AHeight = Height) then Exit;
  end;
  Result := TGlyphList.CreateSize(AWidth, AHeight);
  GlyphLists.Add(Result);
end;

procedure TGlyphCache.ReturnList(List: TGlyphList);
begin
  if List = nil then Exit;
  if List.Count = 0 then begin
    GlyphLists.Remove(List);
    List.Free;
  end;
end;

function TGlyphCache.Empty: Boolean;
begin
  Result := GlyphLists.Count = 0;
end;

var
  GlyphCache: TGlyphCache = nil;
  Pattern: TBitmap = nil;
  PatternBtnFace, PatternBtnHighlight: TColor;
  ButtonCount: Integer = 0;

procedure CreateBrushPattern;
var
  X, Y: Integer;
begin
  PatternBtnFace := GetSysColor(COLOR_BTNFACE);
  PatternBtnHighlight := GetSysColor(COLOR_BTNHIGHLIGHT);
  Pattern := TBitmap.Create;
  with Pattern do begin
    Width := 8;
    Height := 8;
    with Canvas do begin
      Brush.Style := bsSolid;
      Brush.Color := clBtnFace;
      FillRect (Rect(0, 0, Width, Height));
      for Y := 0 to 7 do
        for X := 0 to 7 do
          if Odd(Y) = Odd(X) then  { toggles between even/odd pixels }
            Pixels[X, Y] := clBtnHighlight;     { on even/odd rows }
    end;
  end;
end;


{ TButtonGlyph }

constructor TButtonGlyph.Create;
var
  B: Boolean;
  I: TButtonState97;
begin
  inherited;
  FCallDormant := True;
  FImageIndex := -1;
  FOriginal := TBitmap.Create;
  FOriginal.OnChange := GlyphChanged;
  FOriginalMask := TBitmap.Create;
  FOriginalMask.OnChange := GlyphChanged;
  FNumGlyphs := 1;
  for B := False to True do
    for I := Low(I) to High(I) do
      FIndexs[B, I] := -1;
  if GlyphCache = nil then
    GlyphCache := TGlyphCache.Create;
end;

destructor TButtonGlyph.Destroy;
begin
  FOriginalMask.Free;
  FOriginal.Free;
  FImageChangeLink.Free;
  Invalidate;
  if Assigned(GlyphCache) and GlyphCache.Empty then begin
    GlyphCache.Free;
    GlyphCache := nil;
  end;
  inherited;
end;

procedure TButtonGlyph.Invalidate;
var
  B: Boolean;
  I: TButtonState97;
begin
  for B := False to True do begin
    for I := Low(I) to High(I) do 
      if FIndexs[B, I] <> -1 then begin
        FGlyphList[B].Delete (FIndexs[B, I]);
        FIndexs[B, I] := -1;
      end;
    GlyphCache.ReturnList (FGlyphList[B]);
    FGlyphList[B] := nil;
  end;
end;

procedure TButtonGlyph.GlyphChanged (Sender: TObject);
begin
  if (Sender = FOriginal) and (FOriginal.Width <> 0) and (FOriginal.Height <> 0) then
    FTransparentColor := FOriginal.Canvas.Pixels[0, FOriginal.Height-1] or $02000000;
  Invalidate;
  if Assigned(FOnChange) then FOnChange (Self);
end;

procedure TButtonGlyph.UpdateNumGlyphs;
var
  Glyphs: Integer;
begin
  if (FOriginal.Width <> 0) and (FOriginal.Height <> 0) and
     (FOriginal.Width mod FOriginal.Height = 0) then begin
    Glyphs := FOriginal.Width div FOriginal.Height;
    if Glyphs > High(TNumGlyphs97) then Glyphs := 1;
  end
  else
    Glyphs := 1;
  SetNumGlyphs (Glyphs);
end;

procedure TButtonGlyph.SetGlyph (Value: TBitmap);
begin
  Invalidate;
  FOriginal.Assign (Value);
  UpdateNumGlyphs;
end;

procedure TButtonGlyph.SetGlyphMask (Value: TBitmap);
begin
  Invalidate;
  FOriginalMask.Assign (Value);
end;

procedure TButtonGlyph.SetNumGlyphs (Value: TNumGlyphs97);
begin
  Invalidate;
  if (FImageList <> nil) or (Value < Low(TNumGlyphs97)) or
     (Value > High(TNumGlyphs97)) then
    FNumGlyphs := 1
  else
    FNumGlyphs := Value;
  GlyphChanged (nil);
end;

function TButtonGlyph.CreateButtonGlyph (State: TButtonState97): TBoolInt;
const
  ROP_DSPDxax = $00E20746;
  ROP_PSDPxax = $00B8074A;
  ROP_DSna = $00220326;  { D & ~S }

  procedure GenerateMaskBitmapFromDIB (const MaskBitmap, SourceBitmap: TBitmap;
    const SourceOffset, SourceSize: TPoint; TransColors: array of TColor);
  { This a special procedure meant for generating monochrome masks from
    >4 bpp color DIB sections. Because each video driver seems to sport its own
    interpretation of how to handle DIB sections, a workaround procedure like
    this was necessary. }
  type
    TColorArray = array[0..536870910] of TColorRef;
  var
    Info: packed record
      Header: TBitmapInfoHeader;
      Colors: array[0..1] of TColorRef;
    end;
    W, H: Integer;
    I, Y, X: Integer;
    Pixels: ^TColorArray;
    Pixel: ^TColorRef;
    MonoPixels: Pointer;
    MonoPixel, StartMonoPixel: ^Byte;
    MonoScanLineSize, CurBit: Integer;
    DC: HDC;
    MaskBmp: HBITMAP;
  begin
    W := SourceBitmap.Width;
    H := SourceBitmap.Height;
    MonoScanLineSize := SourceSize.X div 8;
    if SourceSize.X mod 8 <> 0 then
      Inc (MonoScanLineSize);
    if MonoScanLineSize mod 4 <> 0 then  { Compensate for scan line boundary }
      MonoScanLineSize := (MonoScanLineSize and not 3) + 4;
    MonoPixels := AllocMem(MonoScanLineSize * SourceSize.Y);  { AllocMem is used because it initializes to zero }
    try
      GetMem (Pixels, W * H * 4);
      try
        FillChar (Info, SizeOf(Info), 0);
        with Info do begin
          with Header do begin
            biSize := SizeOf(TBitmapInfoHeader);
            biWidth := W;
            biHeight := -H;  { negative number makes it a top-down DIB }
            biPlanes := 1;
            biBitCount := 32;
            {biCompression := BI_RGB;}  { implied due to the FillChar zeroing }
          end;
          {Colors[0] := clBlack;}  { implied due to the FillChar zeroing }
          Colors[1] := clWhite;
        end;
        DC := CreateCompatibleDC(0);
        GetDIBits (DC, SourceBitmap.Handle, 0, H, Pixels, PBitmapInfo(@Info)^,
          DIB_RGB_COLORS);