こんにちは、佐藤　充男です。



TImageを継承して作成した、縦横比をキープしたまま拡大、縮小表示する
カスタムコンポです。制限は多いけど、自分では便利だと思っています（笑）
動作確認はDelphi5 Professionalで行いました。


【設計時プロパティ】　プロパティを３個追加しています。
●「縦横比をキープしてストレッチ描画」
  property AdvancedStretch: Boolean;

    このプロパティで縦横比をキープしたまま制限サイズ内に描画します。
    Trueでオン（初期値）。False でオフ。

●「高さ制限」
  property LimitHeight: Integer;

    縦横比をキープするためHeightプロパティを操作するので、その最大
    高さを制限するプロパティです。初期値はHeight値と同じ。

●「幅制限」
  property LimitWidth: Integer;

    縦横比をキープするためWidthプロパティを操作するので、その最大
    幅を制限するプロパティです。初期値はWidth値と同じ。


【備考】
・縦横比の調整はHeight、Widthプロパティを直接Paintメソッド内で操作する
　という超手抜きです。
・実行中にHeight、Width を変更する場合は、LimitHeight、LimitWidth
　も同時に変更してください。
・AdvancedStretch が True の時に
      Stretch  を False    にする
      AutoSize を Treu     にする
      Align    を alNone   以外にするのはダメです(^^;
  他にも制限があるかもしれません。


//=== ここから ========================================================
unit SaImage;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  TSaImage = class(TImage)
  private
    { Private 宣言 }
    // プロパティ変数
    FAdvancedStretch: Boolean; // 縦横比をそのままにストレッチ表示
    FLimitHeight: Integer;  // 高さ制限
    FLimitWidth:  Integer;  // 幅制限

    FDuplexCall: Boolean; // 多重呼び出し禁止フラグ
    // 画像が変化したことを判断するための変数
    FNowHeight: Integer;  // 現在のImageの高さ
    FNowWidth: Integer;   // 現在のImageの幅
    FImgHeight: Integer;  // 画像の高さ
    FImgWidth: Integer;   // 画像の幅
    FOldLimitHeight: Integer;  // 高さ制限変化判断用
    FOldLimitWidth: Integer;   // 幅制限変化判断用

    // プロパティ操作
    procedure SetAdvancedStretch(Value: Boolean);
    procedure SetLimitHeight(Value: Integer);
    procedure SetLimitWidth(Value: Integer);
  protected
    { Protected 宣言 }
    procedure Paint; override;
    procedure Resize; override;
  public
    { Public 宣言 }
    constructor Create(AOwner: TComponent); override;
  published
    { Published 宣言 }
    // 設計時プロパティ
    property AdvancedStretch: Boolean read FAdvancedStretch
                              write SetAdvancedStretch default True;
    property LimitHeight: Integer read FLimitHeight write SetLimitHeight;
    property LimitWidth: Integer read FLimitWidth  write SetLimitWidth;

    property Stretch default True;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('SaCompo', [TSaImage]);
end;

//----------------------------------------------------------------------
(* コンストラクタ *)
constructor TSaImage.Create(AOwner: TComponent);
begin
  Inherited Create(AOwner);

  FAdvancedStretch := True;
  FLimitHeight := Height;
  FOldLimitHeight := FLimitHeight;
  FLimitWidth  := Width;
  FOldLimitWidth := FLimitWidth;

  Stretch := True;

  FDuplexCall := False;
  FNowHeight := 0;
  FNowWidth  := 0;
  FImgHeight := 0;
  FImgWidth  := 0;
end;

//----------------------------------------------------------------------
(* プロパティ操作 *)
procedure TSaImage.SetAdvancedStretch(Value: Boolean);
begin
  if FAdvancedStretch <> Value then
  begin
    FAdvancedStretch := Value;
    if Value = False then
    begin
      Height := FLimitHeight;
      Width  := FLimitWidth;
    end;
    Self.Refresh;
  end;
end;

procedure TSaImage.SetLimitHeight(Value: Integer);
begin
  if (FLimitHeight <> Value) and (Value > 0) then
  begin
    FOldLimitHeight := FLimitHeight;
    FLimitHeight := Value;
    Self.Refresh;
  end;
end;

procedure TSaImage.SetLimitWidth(Value: Integer);
begin
  if (FLimitWidth <> Value) and (Value > 0) then
  begin
    FOldLimitWidth := FLimitWidth;
    FLimitWidth := Value;
    Self.Refresh;
  end;
end;

//----------------------------------------------------------------------
procedure TSaImage.Paint;
var
  HRate, WRate: Extended;
  iwork: Integer;
  flag: Boolean;
begin
  if FDuplexCall then
    Exit;  // 多重呼び出しなので処理から抜ける

  flag := False;
  if FAdvancedStretch then
  begin
    if (FNowHeight <> Height) or (FNowWidth <> Width) then
      flag := True;  // 縦横比の合わす最中だと判断！
    if (FImgHeight <> Picture.Height) or (FImgWidth <> Picture.Width) then
      flag := True;  // 以前表示していた絵のサイズが変化した！
    if (FOldLimitHeight <> FLimitHeight) or
              (FOldLimitWidth <> FLimitWidth) then
      flag := True;  // 制限サイズが変化した
  end;

  if flag then
  begin
    if (Picture.Height > 0) and (Picture.Width > 0) then
    begin
      // Picture に画像が存在している場合
      FDuplexCall := True;

      // LimitHeight に合わせてテストする
      HRate := FLimitHeight / Picture.Height;
      iwork := Trunc(Picture.Width * HRate);
      if iwork < FLimitWidth then
      begin
        // LimitHeight に合わせてストレッチする
        FNowHeight := Trunc(Picture.Height * HRate);
        FnowWidth  := iwork;
      end
      else
      begin
        // LimitWidth に合わせてストレッチする
        WRate := FLimitWidth / Picture.Width;
        FNowHeight := Trunc(Picture.Height * WRate);
        FNowWidth  := Trunc(Picture.Width  * WRate);
      end;

      // 高さ、幅が０にならないようにする
      if FNowHeight = 0 then FNowHeight := 1;
      if FNowWidth  = 0 then FNowWidth := 1;

      SetBounds(Left, Top, FNowWidth, FNowHeight);
      FImgHeight := Picture.Height;
      FImgWidth  := Picture.Width;

      FDuplexCall := False;
    end;
  end;

  inherited Paint;
end;

procedure TSaImage.Resize;
begin
  // 設計時のサイズ変更に対応
  inherited Resize;
  if csDesigning in ComponentState then  // 設計時
  begin
    FLimitHeight := Height;
    FLimitWidth  := Width;
  end;
end;

end.
//=== ここまで ========================================================

                              2000/3/3(金) 00:50pm  LDM03756 佐藤　充男

Original document by 佐藤　充男　　　氏 ID:(LDM03756)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。