tb97ctls.pas

企业智能(ERP)管理系统

                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: Integer; State: TButtonState97);
begin
  with Canvas do begin
    if State = bsDisabled then begin
      Pen.Color := clBtnHighlight;
      Brush.Color := clBtnHighlight;
      Polygon ([Point(X+5, Y+1), Point(X+9, Y+1), Point(X+7, Y+3)]);
      Pen.Color := clBtnShadow;
      Brush.Color := clBtnShadow;
      Polygon ([Point(X+4, Y), Point(X+8, Y), Point(X+6, Y+2)]);
    end
    else begin
      Pen.Color := Font.Color;
      Brush.Color := Font.Color;
      Polygon ([Point(X+4, Y), Point(X+8, Y), Point(X+6, 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; var GlyphPos, ArrowPos: TPoint; var TextBounds: TRect);
var
  TextPos: TPoint;
  ClientSize, GlyphSize, TextSize, ArrowSize: TPoint;
  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;

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

  LayoutLeftOrRight := Layout in [blGlyphLeft, blGlyphRight];
  if not LayoutLeftOrRight and ((GlyphSize.X = 0) or (GlyphSize.Y = 0)) 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 (GlyphSize.X <> 0) and (GlyphSize.Y <> 0) 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 (GlyphSize.X = 0) or (GlyphSize.Y = 0) 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
     (GlyphSize.X = 0) or (GlyphSize.Y = 0) 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;
  if (GlyphSize.X = 0) or (GlyphSize.Y = 0) 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
    Inc (X, Client.Left + Offset.X);
    Inc (Y, Client.Top + Offset.Y);
  end;
  OffsetRect (TextBounds, TextPos.X + Client.Left + Offset.X,
    TextPos.Y + Client.Top + Offset.X);
end;

function TButtonGlyph.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;
var
  GlyphPos, ArrowPos: TPoint;
begin
  CalcButtonLayout (Canvas, Client, Offset, DrawGlyph, DrawCaption, Caption,
    WordWrap, Layout, Margin, Spacing, DropArrow, GlyphPos, ArrowPos, Result);
  if DrawGlyph then
    DrawButtonGlyph (Canvas, GlyphPos, State);
  if DrawCaption then
    DrawButtonText (Canvas, Caption, Result, WordWrap, Alignment, State);
  if DropArrow then
    DrawButtonDropArrow (Canvas, ArrowPos.X, ArrowPos.Y, State);
end;


{ TDropdownList }

{$IFNDEF TB97D4}

type
  TDropdownList = class(TComponent)
  private
    List: TList;
    Window: HWND;
    procedure WndProc (var Message: TMessage);
  protected
    procedure Notification (AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddMenu (Menu: TPopupMenu);
  end;
var
  DropdownList: TDropdownList;

constructor TDropdownList.Create (AOwner: TComponent);
begin
  inherited;
  List := TList.Create;
end;

destructor TDropdownList.Destroy;
begin
  List.Free;
  inherited;
end;

procedure TDropdownList.WndProc (var Message: TMessage);
{ This procedure is based on code from TPopupList.WndProc (menus.pas) }
var
  I: Integer;
  MenuItem: TMenuItem;
  FindKind: TFindItemKind;
  ContextID: Integer;
begin
  try
    with List do
      case Message.Msg of
        WM_COMMAND:
          for I := 0 to Count-1 do
            if TPopupMenu(Items[I]).DispatchCommand(TWMCommand(Message).ItemID) then
              Exit;
        WM_INITMENUPOPUP:
          for I := 0 to Count-1 do
            if TPopupMenu(Items[I]).DispatchPopup(TWMInitMenuPopup(Message).MenuPopup) then
              Exit;