vkbmpbutton.pas

Delphi7的一个支持位图的控件源码.将位图切成4份.

    Invalidate;
  end;
end;

procedure TVkBmpButton.SetMaskColor(const Value: TColor);
begin
  if FMaskColor <> Value then
  begin
    FMaskColor := Value;
    Invalidate;
  end;
end;

procedure TVkBmpButton.SetTransparent(const Value: Boolean);
begin
   FTransparent := Value;
end;

procedure TVkBmpButton.SetStatus(const Value: Integer);
begin
   FStatus := Value;
end;

procedure TVkBmpButton.SetProgress(const Value: Integer);
begin
   FProgress := Value;
end;

procedure TVkBmpButton.SetData(const Value: TObject);
begin
   FData := Value;
end;

procedure TVkBmpButton.SetNormalIndex(const Value: Integer);
begin
  if FNormalIndex <> Value then
  begin
    FNormalIndex := Value;
    Invalidate;
  end;
end;




{ TImgButton }

procedure TImgButton.CMMouseEnter(var Message: TMessage);
begin
  if (not FBitmap.Empty) and (FGraphicNums > 0) then
  begin
    if MouseCapture then
    begin
      if (FDownIndex >= 0) and (FDownIndex < FGraphicNums) then
        DrawBtn(FDownIndex);
    end else
    begin
      if (FHighLightIndex >= 0) and (FHighLightIndex < FGraphicNums) then
        DrawBtn(FHighLightIndex);
    end;
  end;

  inherited;
end;

procedure TImgButton.CMMouseLeave(var Message: TMessage);
begin
  if (not FBitmap.Empty) and (FGraphicNums > 0)
    and (FHighLightIndex >= 0) and (FHighLightIndex < FGraphicNums) then
    DrawBtn(FNormalIndex);

    inherited;
end;

constructor TImgButton.Create(AOwner: TComponent);
begin
  inherited;
  FBitmap := TBitmap.Create;
  FBitmap.OnChange := OnBitmapChanged;

  FGraphicNums := 1;

  FNormalIndex := 0;
  FDownIndex := 1;
  FDisableIndex := 2;
  FHighLightIndex := 3;

  FMaskColor := clWhite;
end;

destructor TImgButton.Destroy;
begin
  FBitmap.Free;
  inherited;
end;

procedure TImgButton.DrawBtn(ImageIndex: Integer);
var
  R: TRect;
begin
  if (ImageIndex >= FGraphicNums) or (ImageIndex < 0) then ImageIndex := FNormalIndex;

  R.Left := ImageIndex * Width;
  R.Top := 0;
  R.Right := R.Left + Width;
  R.Bottom := Height;

  FBitmap.TransparentColor := FBitmap.Canvas.Pixels[0, 0];
  Canvas.Brush.Style := bsClear;
  Canvas.BrushCopy(ClientRect, FBitmap, R, FMaskColor);
end;

procedure TImgButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;

  if (Button = mbLeft) and (not FBitmap.Empty) and (FGraphicNums > 0)
    and (FDownIndex >= 0) and (FDownIndex < FGraphicNums) then
    DrawBtn(FDownIndex);
end;

procedure TImgButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;

  if (Button = mbLeft) and (not FBitmap.Empty) and (FGraphicNums > 0) then
  begin
    if (PtInRect(ClientRect, Point(X, Y))) then
      DrawBtn(FHighLightIndex)
    else
      DrawBtn(FNormalIndex);
  end;
end;

procedure TImgButton.OnBitmapChanged(Sender: TObject);
begin
  ResizeMe;
end;

procedure TImgButton.Paint;
begin
  if Enabled then DrawBtn(NormalIndex)
  else DrawBtn(DisableIndex);
end;

procedure TImgButton.ResizeMe;
begin
  if (FBitmap.Empty) or (FGraphicNums <= 0) then
  begin
    Width := 75;
    Height := 25;
  end else
  begin
    Width := FBitmap.Width div FGraphicNums;
    Height := FBitmap.Height;
  end;
end;

procedure TImgButton.SetBitmap(const Value: TBitmap);
begin
  FBitmap.Assign(Value);
  Invalidate;
end;

procedure TImgButton.SetDisableIndex(const Value: Integer);
begin
  if FDisableIndex <> Value then
  begin
    FDisableIndex := Value;
    Invalidate;
  end;
end;

procedure TImgButton.SetDownIndex(const Value: Integer);
begin
  if FDownIndex <> Value then
  begin
    FDownIndex := Value;
    Invalidate;
  end;
end;

procedure TImgButton.SetGraphicNums(const Value: Integer);
begin
  if FGraphicNums <> Value then
  begin
    FGraphicNums := Value;
    ResizeMe;
    Invalidate;
  end;
end;

procedure TImgButton.SetHighLightIndex(const Value: Integer);
begin
  if FHighLightIndex <> Value then
  begin
    FHighLightIndex := Value;
    Invalidate;
  end;
end;

procedure TImgButton.SetMaskColor(const Value: TColor);
begin
  if FMaskColor <> Value then
  begin
    FMaskColor := Value;
    Invalidate;
  end;
end;

procedure TImgButton.SetNormalIndex(const Value: Integer);
begin
  if FNormalIndex <> Value then
  begin
    FNormalIndex := Value;
    Invalidate;
  end;
end;

{ TImgMovie }

constructor TImgMovie.Create;
begin
  inherited;

  FGraphicNums := 1;
  FMaskColor := clWhite;

  FBitmap := TBitmap.Create;
  FBitmap.OnChange := OnBitmapChanged;

  FTimer := TTimer.Create(Self);
  FTimer.Enabled := false;
  FTimer.Interval := 300;
  FTimer.OnTimer := OnTimer;
end;

destructor TImgMovie.Destroy;
begin
  FBitmap.Free;
  
  inherited;
end;

procedure TImgMovie.DrawImage;
var
  R: TRect;
begin
  if (FIndex >= FGraphicNums) or (FIndex < 0) then FIndex := 0;

  R.Left := FIndex * Width;
  R.Top := 0;
  R.Right := R.Left + Width;
  R.Bottom := Height;

  Canvas.Brush.Style := bsClear;
  Canvas.BrushCopy(ClientRect, FBitmap, R, FMaskColor);
end;

function TImgMovie.GetInterval: Cardinal;
begin
  Result := FTimer.Interval;
end;

procedure TImgMovie.OnBitmapChanged(Sender: TObject);
begin
  ResizeMe();
end;

procedure TImgMovie.OnTimer(Sender: TObject);
begin
  FIndex := FIndex + 1;

  if FIndex >= FGraphicNums then FIndex := 0;

  Invalidate;
end;

procedure TImgMovie.Paint;
begin
  DrawImage;
end;

procedure TImgMovie.ResizeMe;
begin
  if (FBitmap.Empty) or (FGraphicNums <= 0) then
  begin
    Width := 75;
    Height := 25;
  end else
  begin
    Width := FBitmap.Width div FGraphicNums;
    Height := FBitmap.Height;
  end;
end;

procedure TImgMovie.SetActived(const Value: Boolean);
begin
  if Value and (FBitmap.Empty or (FGraphicNums <= 1)) then Exit;
  
  if (FActived <> Value) then
  begin
    FActived := Value;

    FIndex := 0;
    DrawImage;
    FTimer.Enabled := FActived;
  end;
end;

procedure TImgMovie.SetBitmap(const Value: TBitmap);
begin
  FBitmap.Assign(Value);
end;

procedure TImgMovie.SetGraphicNums(const Value: Integer);
begin
  if FGraphicNums <> Value then
  begin
    FGraphicNums := Value;
    ResizeMe;
    Invalidate;
  end;
end;

procedure TImgMovie.SetInterval(const Value: Cardinal);
begin
  FTimer.Interval := Value;
end;

procedure TImgMovie.SetMaskColor(const Value: TColor);
begin
  if FMaskColor <> Value then
  begin
    FMaskColor := Value;
    Invalidate;
  end;
end;

end.