Delphi - 看一下TImage控件代码
技术交流,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;
代码的确很短,也就是把图像从Picture上Copy到画布.主要他这里面用到了一个缓冲绘图,不过这个只有Vista下面才行的.
是的,TImage也就这样了.挺简单的.
