iimagedisplay.pas

iocopm3.04源码,一套很好的工控开发工具

{$IFDEF iVCL}
var
  SA: TStreamAdapter;
{$ENDIF}
begin
 {$IFDEF iVCL}
  FImageList.Clear;
  SA := TStreamAdapter.Create(Stream);
  try
    FImageList.Handle := ImageList_Read(SA);
    if FImageList.Handle = 0 then raise EReadError.Create('Failed to read ImageList data from stream');
  finally
    SA.Free;
  end;
 {$ENDIF}
 {$IFDEF iCLX}
 FImageList.ReadData(Stream);
 {$ENDIF}

 if not GetIsDesigning then if FTimerEnabled then TimerStart(FTimerInterval, FTimerInterval);
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.WriteImageList(Stream: TStream);
{$IFDEF iVCL}
var
  SA: TStreamAdapter;
{$ENDIF}
begin
 {$IFDEF iVCL}
  SA := TStreamAdapter.Create(Stream);
  try
    if not ImageList_Write(FImageList.Handle, SA) then raise EWriteError.Create('Failed to write ImageList data to stream');
  finally
    SA.Free;
  end;
 {$ENDIF}
 {$IFDEF iCLX}
 FImageList.WriteData(Stream);
 {$ENDIF}
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.ImageListClear;
begin
  FImageList.Clear;
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.ImageListLoadFromBitmap(ABitmap: TBitmap);
var
  BBitmap    : TBitmap;
  OffsetX    : Integer;
  OffsetY    : Integer;
begin
  if FImageList.Count = 0 then
    begin
      FImageList.Width  := ABitmap.Width;
      FImageList.Height := ABitmap.Height;
    end
  else if (ABitmap.Width < FImageList.Width) and (ABitmap.Height < FImageList.Height) then
    begin
      BBitmap := TBitmap.Create;
      try
        BBitmap.Width  := FImageList.Width;
        BBitmap.Height := FImageList.Height;

        BBitmap.Canvas.Brush.Style := bsSolid;
        BBitmap.Canvas.Brush.Color := ABitmap.TransparentColor;
        BBitmap.Canvas.FillRect(Rect(0, 0, BBitmap.Width, BBitmap.Height));

        OffsetX := BBitmap.Width  div 2 - ABitmap.Width  div 2;
        OffsetY := BBitmap.Height div 2 - ABitmap.Height div 2;

        BBitmap.Canvas.Draw(OffsetX, OffsetY, ABitmap);

        ABitmap.Assign(BBitmap);
      finally
        BBitmap.Free;
      end;
    end
  else if (ABitmap.Width > FImageList.Width) and (ABitmap.Height > FImageList.Height) then
    begin

    end
  else if (ABitmap.Width <> FImageList.Width) and (ABitmap.Height <> FImageList.Height) then
    raise Exception.Create('Image Width and Height must be the same as other images, or both smaller, or both larger');

  FImageList.InsertMasked(FImageList.Count, ABitmap, ABitmap.TransparentColor);

  InvalidateChange;
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.ImageListLoadFromResourceID(Instance: Cardinal; ResID: Integer);
var
  ABitmap : TBitmap;
begin
  ABitmap := TBitmap.Create;
  try
    ABitmap.LoadFromResourceID(Instance, ResID);
    ImageListLoadFromBitmap(ABitmap);
  finally
    ABitmap.Free;
  end;
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.ImageListLoadFromResourceName(Instance: Cardinal; ResName: String);
var
  ABitmap : TBitmap;
begin
  ABitmap := TBitmap.Create;
  try
    ABitmap.LoadFromResourceName(Instance, ResName);

    ImageListLoadFromBitmap(ABitmap);
  finally
    ABitmap.Free;
  end;
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.ImageListAdd(ABitmap: TBitmap);
begin
  ImageListLoadFromBitmap(ABitmap);
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.iPaintTo(Canvas: TCanvas);
var
  AX     : Integer;
  AY     : Integer;
  Bitmap : TBitmap;
begin
  DrawBackGround(Canvas, BackGroundColor);

  if (FImageList.Count <> 0) and (FImageIndex < FImageList.Count) then
    begin
      AX := Width  div 2 - FImageList.Width  div 2;
      AY := Height div 2 - FImageList.Height div 2;

      if not FStretched then
        begin
          {$ifdef iVCL}FImageList.Draw(Canvas, AX, AY, FImageIndex,          True);{$endif}
          {$ifdef iCLX}FImageList.Draw(Canvas, AX, AY, FImageIndex, itImage, True);{$endif}
        end
      else
        begin
          Bitmap := TBitmap.Create;
          try
            DrawBackGround(Bitmap.Canvas, BackGroundColor);
            Bitmap.Width  := FImageList.Width;
            Bitmap.Height := FImageList.Height;

            {$ifdef iVCL}FImageList.Draw(Bitmap.Canvas, 0, 0, FImageIndex,          True);{$endif}
            {$ifdef iCLX}FImageList.Draw(Bitmap.Canvas, 0, 0, FImageIndex, itImage, True);{$endif}

            Canvas.StretchDraw(ClientRect, Bitmap);
          finally
            Bitmap.Free;
          end;
        end;
    end;

  DrawBorder(Canvas);
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.TimerEvent(Sender: TObject);
begin
  if FTimerIncrementUp then
    begin
      Inc(FImageIndex);
      if FTimerAutoRepeat then
        begin
          if FImageIndex > (FImageList.Count-1) then FImageIndex := 0;
        end
      else
        begin
          if FImageIndex > (FImageList.Count-1) then
            begin
              TimerStop;
              FImageIndex := FImageList.Count-1;
            end;
        end;
    end
  else
    begin
      Dec(FImageIndex);
      if FTimerAutoRepeat then
        begin
          if FImageIndex < 0 then FImageIndex := (FImageList.Count-1);
        end
      else
        begin
          if FImageIndex < 0 then
            begin
              TimerStop;
              FImageIndex := 0;
            end;
        end;
    end;
  InvalidateChange;
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.GotoFirstImage;
begin
  FImageIndex := 0;
  InvalidateChange;
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.GotoLastImage;
begin
  FImageIndex := FImageList.Count-1;
  InvalidateChange;
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.ImageListChange(Sender: TObject);
begin
  InvalidateChange;
  DoAutoSize;
end;
//****************************************************************************************************************************************************
procedure TiImageDisplay.SetBorderStyle(const Value: TiBevelStyle);
begin
  inherited;
  DoAutoSize;
end;
//****************************************************************************************************************************************************
end.