请选择 进入手机版 | 继续访问电脑版

Lazarus中文社区

 找回密码
 立即注册

QQ登录

只需一步,快速开始

Lazarus IDE and 组件 下载地址版权申明
查看: 344|回复: 0

带图片背景的Panel控件源代码:TImagePanel

[复制链接]
  • TA的每日心情
    开心
    昨天 13:43
  • 签到天数: 259 天

    [LV.8]以坛为家I

    发表于 2017-12-1 12:01:50 | 显示全部楼层 |阅读模式
    本帖最后由 bjchang888 于 2017-12-1 12:06 编辑

    网上的DELPHI资源,我没事学习一下,在Lazarus下改编了一点点。处理了Caption乱码。测试样图

    unit imagepanel;

    {$mode objfpc}{$H+}

    interface

    uses
      Classes, Windows, ExtCtrls, Graphics, Controls;

    type

      { TImagePanel }

      TImagePanel = class(TCustomPanel)
      private
        FAutoSize: boolean;
        FPicture: TPicture;
        FTransparent: boolean;
        procedure SetPicture(AValue: TPicture);
        procedure SetTransparent(AValue: boolean);
        procedure SetAutoImgSize(AValue: Boolean);
        procedure PictureChanged(Sender: TObject);
      protected
        procedure Paint(); override;
      public
        constructor Create(AOwner: TComponent); override;
        destructor Destroy(); override;
      published
        property Picture: TPicture read FPicture write SetPicture;
        property Transparent: boolean read FTransparent write SetTransparent default False;
        property AutoSize: boolean read FAutoSize write SetAutoImgSize;

        property Font;
        property Caption;
        property Alignment;
        property color;
      end;


    procedure Register;

    implementation

    procedure Register;
    begin
      RegisterComponents('Flsoft', [TImagePanel]);
    end;

    { TImagePanel }

    procedure TImagePanel.SetPicture(AValue: TPicture);
    begin
      if FPicture = AValue then
        Exit;
      FPicture.Assign(AValue);
      RePaint();
    end;

    procedure TImagePanel.SetTransparent(AValue: boolean);
    begin
      if FTransparent = AValue then
        Exit;
      FTransparent := AValue;
      RePaint();
    end;

    procedure TImagePanel.SetAutoImgSize(AValue: boolean);
    begin
      if FAutoSize = AValue then
        exit;
      FAutoSize := AValue;
      Repaint();
    end;

    procedure TImagePanel.PictureChanged(Sender: TObject);
    begin
      RePaint();
    end;

    procedure TImagePanel.Paint();
    const
      Alignments: array[TAlignment] of longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
    var
      Flags: longint;
      Rect: TRect;
      FontHeight: integer;
    begin
      Canvas.Brush.Style := bsClear;
      Canvas.Font := Font;
      if Assigned(FPicture.Graphic) then
      begin
        if FAutoSize then
        begin
          Width := FPicture.Width;
          Height := FPicture.Height;
        end;
        if FPicture.Graphic.Transparent <> FTransparent then
          FPicture.Graphic.Transparent := FTransparent;
        Canvas.StretchDraw(ClientRect, FPicture.Graphic);
      end
      else
      begin
        Canvas.Brush.Color := Color;
        Canvas.FillRect(ClientRect);
      end;

      if Caption <> '' then
      begin
        Rect := GetClientRect;
        FontHeight := Canvas.TextHeight('W');
        Rect.Top := ((Rect.Bottom + Rect.Top) - FontHeight) div 2;
        Rect.Bottom := Rect.Top + FontHeight;
        Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[Alignment];
        DrawTextW(Canvas.Handle, PWideChar(UTF8ToString(caption)), -1, Rect, Flags);
      end;
    end;

    constructor TImagePanel.Create(AOwner: TComponent);
    begin
      inherited Create(AOwner);

      FPicture := TPicture.Create;
      FPicture.OnChange := @PictureChanged;
      RePaint();
    end;

    destructor TImagePanel.Destroy();
    begin
      FPicture.Free;
      FPicture := nil;
      inherited Destroy();
    end;

    end.


    本帖子中包含更多资源

    您需要 登录 才可以下载或查看,没有帐号?立即注册

    x
    回复

    使用道具 举报

    QQ|手机版|小黑屋|Lazarus中国|Lazarus中文社区 ( 鄂ICP备16006501号-1

    GMT+8, 2017-12-16 23:01 , Processed in 0.112301 second(s), 9 queries , Redis On.

    Powered by Discuz! F1.0 Build 20160930

    © 2001-2017 Comsenz Inc. & Discuz! Fans

    快速回复 返回顶部 返回列表