Delphi-看一下TImage控件代码

原作者: [db:作者] 来自: [db:来源] 收藏邀请

技术交流,DH讲解.

TImage控件是我们用得比较多的一个控件了,那么它是怎么实现的呢?
当然它也不需要输入这些,所以它是从TGraphicControl继承下来,那么也就是只要在重载Paint方法,把图形画到画布上面就可以了.
好的我们来看看它的声明:

TImage = class(TGraphicControl)
  private
    //图形
    FPicture: TPicture;
    FOnProgress: TProgressEvent;
    //是否拉升图像
    FStretch: Boolean;
    //图像居中
    FCenter: Boolean;
    //
    FIncrementalDisplay: Boolean;
    //透明
    FTransparent: Boolean;
    //正在画图中???
    FDrawing: Boolean;
    //保持比例缩放
    FProportional: Boolean;
    //FPicture的OnChange事件的方法
    procedure PictureChanged(Sender: TObject);
    //Getter
    function GetCanvas: TCanvas;
    //Setter,都调用PictureChanged来刷新
    procedure SetCenter(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure SetStretch(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure SetProportional(Value: Boolean);
  protected
    //返回都是True,主要是对参数进行了重新赋值
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    //这两个方法在PictureChanged中被调用
    function DestRect: TRect;
    function DoPaletteChange: Boolean;
    //Getter
    function GetPalette: HPALETTE; override;
    procedure Paint; override;
    procedure Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TCanvas read GetCanvas;
  published
    property Align;
    property Anchors;
    property AutoSize;
    property Center: Boolean read FCenter write SetCenter default False;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
    property ParentShowHint;
    property Picture: TPicture read FPicture write SetPicture;
    property PopupMenu;
    property Proportional: Boolean read FProportional write SetProportional default false;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Touch;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnGesture;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
    property OnStartDock;
    property OnStartDrag;
  end;

个人习惯,我喜欢先看属性的Getter和Setter方法:

function TImage.GetCanvas: TCanvas;
var
  Bitmap: TBitmap;
begin
  //如果Graphic是空就建立一个新的给它
  if Picture.Graphic = nil then
  begin
    Bitmap := TBitmap.Create;
    try
      Bitmap.Width := Width;
      Bitmap.Height := Height;
      //这里的Graphic是一个属性,所以不是直接赋值的
      //所以后面Bitmap.Free不影响Graphic
      Picture.Graphic := Bitmap;
    finally
      Bitmap.Free;
    end;
  end;
  //返回Canvas
  if Picture.Graphic is TBitmap then
    Result := TBitmap(Picture.Graphic).Canvas
  else
    raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
end;

procedure TImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    PictureChanged(Self);
  end;
end;

procedure TImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;

procedure TImage.SetStretch(Value: Boolean);
begin
  if Value <> FStretch then
  begin
    FStretch := Value;
    PictureChanged(Self);
  end;
end;

procedure TImage.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
    FTransparent := Value;
    PictureChanged(Self);
  end;
end;

procedure TImage.SetProportional(Value: Boolean);
begin
  if FProportional <> Value then
  begin
    FProportional := Value;
    PictureChanged(Self);
  end;
end;

在前面的TShape控件中我们说到了,涉及到图形的属性修改后都要重绘一下.那么从上面看,我们可以猜到了PictureChanged这个方法肯定调用了重绘.

procedure TImage.PictureChanged(Sender: TObject);
var
  G: TGraphic;
  D : TRect;
begin
  //如果自动适应大小,那么调整TImage控件的大小.
  if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
	  SetBounds(Left, Top, Picture.Width, Picture.Height);
  //
  G := Picture.Graphic;
  if G <> nil then
  begin
    //是能设置透明的图像,那么就设置其透明和TImage控件一样
    if not ((G is TMetaFile) or (G is TIcon)) then
      G.Transparent := FTransparent;
    //获得实际绘画区域
    D := DestRect;
    //不透明就需要加上csOpaque
    if (not G.Transparent) and
       (D.Left <= 0) and
       (D.Top <= 0) and
       (D.Right >= Width) and
       (D.Bottom >= Height)
    then
      ControlStyle := ControlStyle + [csOpaque]
    else  // picture might not cover entire clientrect
      ControlStyle := ControlStyle - [csOpaque];
    //调用UpdateWindow API
    if DoPaletteChange and FDrawing then Update;
  end
  else
    ControlStyle := ControlStyle - [csOpaque];//当透明处理

  if not FDrawing then Invalidate;
end;

这个方法里面调用另外2个方法:

function TImage.DestRect: TRect;
var
  w, h, cw, ch: Integer;
  xyaspect: Double;
begin
  //图片长宽
  w := Picture.Width;
  h := Picture.Height;
  //控件长宽
  cw := ClientWidth;
  ch := ClientHeight;
  //如果设置了拉升 或 按比例缩放,而且 控件的长或者宽和图片不一致
  if Stretch or (Proportional and ((w > cw) or (h > ch))) then
  begin

    if Proportional and (w > 0) and (h > 0) then
    begin
      //计算长宽比例
      xyaspect := w / h;
      //然后进行调整.
      if w > h then
      begin
        w := cw;
        h := Trunc(cw / xyaspect);
        if h > ch then  // woops, too big
        begin
          h := ch;
          w := Trunc(ch * xyaspect);
        end;
      end
      else
      begin
        h := ch;
        w := Trunc(ch * xyaspect);
        if w > cw then  // woops, too big
        begin
          w := cw;
          h := Trunc(cw / xyaspect);
        end;
      end;
    end
    else  //如果是拉升就直接等于了
    begin
      w := cw;
      h := ch;
    end;
  end;
  //返回
  with Result do
  begin
    Left := 0;
    Top := 0;
    Right := w;
    Bottom := h;
  end;
  //如果要居中,就偏移区域
  if Center then
    OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);
end;

返回TImage的绘图区域,这个方法在Paint中也多次用到.

//如果有父窗体,就发送wm_QueryNewPalette消息给父窗体,然后才会返回成功
function TImage.DoPaletteChange: Boolean;
var
  ParentForm: TCustomForm;
  Tmp: TGraphic;
begin
  Result := False;
  Tmp := Picture.Graphic;
  if Visible and
     (not (csLoading in ComponentState)) and
     (Tmp <> nil) and
     (Tmp.PaletteModified)
  then
  begin
    if (Tmp.Palette = 0) then
      Tmp.PaletteModified := False
    else
    begin
      ParentForm := GetParentForm(Self);
      if Assigned(ParentForm) and
         ParentForm.Active and
         Parentform.HandleAllocated
      then
      begin
        if FDrawing then
          ParentForm.Perform(wm_QueryNewPalette, 0, 0)
        else
          PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
        Result := True;
        Tmp.PaletteModified := False;
      end;
    end;
  end;
end;

这个方法,主要是通知父窗体吧.
好的PictureChanged是重绘,那么绘制什么呢?我们看看Paint方法了

procedure TImage.Paint;

  procedure DoBufferedPaint(Canvas: TCanvas);
  var
    MemDC: HDC;
    Rect: TRect;
    PaintBuffer: HPAINTBUFFER;
  begin
    Rect := DestRect;
    //利用Vista的内建双缓冲绘图???
    PaintBuffer := BeginBufferedPaint(Canvas.Handle, Rect, BPBF_TOPDOWNDIB, nil, MemDC);
    try
      // MemDC由函数BeginBufferedPaint返回
      Canvas.Handle := MemDC;
      Canvas.StretchDraw(DestRect, Picture.Graphic);
      //设置透明度为255
      BufferedPaintMakeOpaque(PaintBuffer, Rect);
    finally
      EndBufferedPaint(PaintBuffer, True);
    end;
  end;

var
  Save: Boolean;
begin
  //设计时期,虚线边框
  if csDesigning in ComponentState then
    with inherited Canvas do
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;
  //Save保存Paint之前的状态
  Save := FDrawing;
  FDrawing := True;
  //缓冲绘图么?
  //csGlassPaint这个只能在Vista上面才能设置
  try
    if (csGlassPaint in ControlState) and
       (Picture.Graphic <> nil) and
       not Picture.Graphic.SupportsPartialTransparency
    then
      DoBufferedPaint(inherited Canvas)
    else
      with inherited Canvas do
        StretchDraw(DestRect, Picture.Graphic);
  finally
    FDrawing := Save;
  end;
end;