gifmain.pas

RxRich很有用的文字图像显示控件,这是它的Demo

    Filter := GraphicFilter(TGraphic);
  end;
  with FSaveDlg do begin
    Name := 'SaveDialog';
    Options := [ofHideReadOnly, ofOverwritePrompt];
    DefaultExt := GraphicExtension(TGIFImage);
    Filter := GraphicFilter(TGIFImage);
  end;
  { Add dialogs to storage }
  with Storage.StoredProps do begin
    AddObject(CreateStoredItem(FOpenDlg.Name, 'InitialDir'), FOpenDlg);
    AddObject(CreateStoredItem(FSaveDlg.Name, 'InitialDir'), FSaveDlg);
  end;
  Application.OnActivate := FormActivate;
  FImage.OnProgress := GraphicProgress;
  FImage.OnChange := ImageChanged;
  Status.Caption := SReady;
  FModified := False;
end;

procedure TAnimatorForm.FormDestroy(Sender: TObject);
begin
  FImage.Free;
end;

procedure TAnimatorForm.FormActivate(Sender: TObject);
begin
  PasteBtn.Enabled := EnablePaste;
end;

procedure TAnimatorForm.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  ConfirmSave;
end;

procedure TAnimatorForm.PreviewBtnClick(Sender: TObject);
begin
  PreviewGIF(FImage);
end;

procedure TAnimatorForm.OpenBtnClick(Sender: TObject);
begin
  ConfirmSave;
  FOpenDlg.Filter := GraphicFilter(TGIFImage);
  try
    if FOpenDlg.Execute then begin
      StartWait;
      FLoading := True;
      try
        FOpenDlg.InitialDir := ExtractFilePath(FOpenDlg.FileName);
        Status.Caption := 'Press <Esc> to cancel';
        Application.ProcessMessages;
        try
          FImage.LoadFromFile(FOpenDlg.FileName);
          FImage.DecodeAllFrames;
          FModified := FImage.Corrupted;
        except
          FImage.Clear;
          FFileName := '';
          raise;
        end;
        FFileName := FOpenDlg.FileName;
        UpdateControls;
      finally
        FLoading := False;
        FAborting := False;
        FModified := FImage.Corrupted;
        StopWait;
        Status.Caption := SReady;
        InvalidateImage(True);
        UpdateCaption;
        EnableButtons;
      end;
    end;
  finally
    FOpenDlg.Filter := GraphicFilter(TGraphic);
  end;
end;

procedure TAnimatorForm.PaintBoxPaint(Sender: TObject);
var
  ImageIndex, Size: Integer;
  W, H, L, T: Integer;
  DrawRect: TRect;
  Frame: TGIFFrame;
begin
  ImageIndex := FTopIndex + TPaintBox(Sender).Tag;
  if (ImageIndex >= 0) and (ImageIndex < FImage.Count) then begin
    DrawRect := TPaintBox(Sender).ClientRect;
    Frame := FImage.Frames[ImageIndex];
    with TPaintBox(Sender).Canvas do begin
      if ImageIndex = FImage.FrameIndex then begin
        Pen.Color := clActiveCaption;
        Pen.Width := 3;
        with DrawRect do Rectangle(Left, Top, Right, Bottom);
      end;
      InflateRect(DrawRect, -3, -3);
      if ThumbnailsBox.Checked then begin
        W := FImage.ScreenWidth;
        H := FImage.ScreenHeight;
        L := Frame.Origin.X;
        T := Frame.Origin.Y;
      end
      else begin
        W := Frame.Width;
        H := Frame.Height;
        L := 0;
        T := 0;
      end;
      if (W <= WidthOf(DrawRect)) and
        (H <= HeightOf(DrawRect)) then
      begin
        DrawRect := Bounds(L, T, Frame.Width, Frame.Height);
      end
      else begin
        Size := DrawRect.Top + MulDiv(H, WidthOf(DrawRect), W);
        if Size > DrawRect.Bottom then begin
          L := MulDiv(L, HeightOf(DrawRect), H);
          T := MulDiv(T, HeightOf(DrawRect), H);
          W := MulDiv(Frame.Width, HeightOf(DrawRect), H);
          H := MulDiv(Frame.Height, HeightOf(DrawRect), H);
          DrawRect := Bounds(L, T, W, H);
        end
        else begin
          L := MulDiv(L, WidthOf(DrawRect), W);
          T := MulDiv(T, WidthOf(DrawRect), W);
          H := MulDiv(Frame.Height, WidthOf(DrawRect), W);
          W := MulDiv(Frame.Width, WidthOf(DrawRect), W);
          DrawRect := Bounds(L, T, W, H);
        end;
      end;
      OffsetRect(DrawRect, 3, 3);
      Frame.Draw(TPaintBox(Sender).Canvas, DrawRect, False);
    end;
  end;
end;

procedure TAnimatorForm.ImageScrollChange(Sender: TObject);
begin
  SetSelectedIndex(ImageScroll.Position, False);
end;

procedure TAnimatorForm.PaintBoxMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  ImageIndex: Integer;
begin
  if (FImage.Count > 0) then begin
    if ImageScroll.Enabled then ActiveControl := ImageScroll;
    ImageIndex := FTopIndex + TPaintBox(Sender).Tag;
    if (ImageIndex >= 0) and (ImageIndex < FImage.Count) then
      SetSelectedIndex(ImageIndex, True);
  end;
end;

procedure TAnimatorForm.NewBtnClick(Sender: TObject);
begin
  ConfirmSave;
  if not FImage.Empty then FImage.Clear;
  FFileName := '';
  UpdateCaption;
  Status.Caption := SReady;
  FModified := False;
end;

procedure TAnimatorForm.SaveBtnClick(Sender: TObject);
begin
  if FFileName = '' then SaveAsBtnClick(Sender)
  else begin
    StartWait;
    try
      FImage.SaveToFile(FFileName);
      FModified := False;
    finally
      StopWait;
      Status.Caption := SReady;
    end;
  end;
end;

procedure TAnimatorForm.SaveAsBtnClick(Sender: TObject);
begin
  if FFileName <> '' then begin
    FSaveDlg.FileName := FFileName;
    FSaveDlg.InitialDir := ExtractFilePath(FSaveDlg.FileName);
  end;
  if not FImage.Empty and FSaveDlg.Execute then begin
    Application.ProcessMessages;
    StartWait;
    try
      FSaveDlg.InitialDir := ExtractFilePath(FSaveDlg.FileName);
      FImage.SaveToFile(FSaveDlg.FileName);
      FModified := False;
      FFileName := FSaveDlg.FileName;
      UpdateCaption;
    finally
      StopWait;
      Status.Caption := SReady;
    end;
  end;
end;

procedure TAnimatorForm.InsertBtnClick(Sender: TObject);
var
  Pic: TPicture;
begin
  if FOpenDlg.Execute then begin
    Application.ProcessMessages;
    StartWait;
    Pic := TPicture.Create;
    try
      FOpenDlg.InitialDir := ExtractFilePath(FOpenDlg.FileName);
{$IFDEF RX_D3}
      Pic.OnProgress := GraphicProgress;
{$ENDIF}
      Pic.LoadFromFile(FOpenDlg.FileName);
      if (Pic.Graphic <> nil) and not Pic.Graphic.Empty then begin
        FImage.AddFrame(Pic.Graphic);
        FModified := True;
        ImageChanged(FImage);
        StartWait;
        try
          FImage.EncodeAllFrames;
        finally
          StopWait;
        end;
      end;
    finally
      Pic.Free;
      StopWait;
      Status.Caption := SReady;
    end;
  end;
end;

procedure TAnimatorForm.PasteBtnClick(Sender: TObject);
var
  Temp: TPicture;
begin
  if not EnablePaste then Exit;
  Temp := TPicture.Create;
  try
    Temp.Assign(Clipboard);
    if (Temp.Graphic <> nil) and not Temp.Graphic.Empty then begin
      FImage.AddFrame(Temp.Graphic);
      FModified := True;
      ImageChanged(FImage);
      StartWait;
      try
        FImage.EncodeAllFrames;
      finally
        StopWait;
      end;
    end;
  finally
    Temp.Free;
    Status.Caption := SReady;
  end;
end;

procedure TAnimatorForm.CutBtnClick(Sender: TObject);
begin
  CopyBtnClick(Sender);
  DeleteBtnClick(Sender);
end;

procedure TAnimatorForm.CopyBtnClick(Sender: TObject);
var
  Temp: TGIFImage;
begin
  if not FImage.Empty and (FImage.FrameIndex >= 0) then begin
    Temp := TGIFImage.Create;
    try
      Temp.Assign(FImage.Frames[FImage.FrameIndex]);
      Clipboard.Assign(Temp);
      PasteBtn.Enabled := EnablePaste;
    finally
      Temp.Free;
    end;
  end;
end;

procedure TAnimatorForm.DeleteBtnClick(Sender: TObject);
begin
  if FImage.FrameIndex >= 0 then begin
    FImage.DeleteFrame(FImage.FrameIndex);
    FModified := True;
  end;
end;

procedure TAnimatorForm.UpBtnClick(Sender: TObject);
begin
  if FImage.FrameIndex > 0 then begin
    FImage.MoveFrame(FImage.FrameIndex, FImage.FrameIndex - 1);
    FModified := True;
  end;
end;

procedure TAnimatorForm.DownBtnClick(Sender: TObject);
begin
  if (FImage.FrameIndex >= 0) and (FImage.FrameIndex < FImage.Count - 1) then
  begin
    FImage.MoveFrame(FImage.FrameIndex, FImage.FrameIndex + 1);
    FModified := True;
  end;
end;

procedure TAnimatorForm.AboutBtnClick(Sender: TObject);
begin
  ShowAbout('RX GIF Image Format Support', 'RX Library Demo Program',
    1, 1, 1998);
end;

procedure TAnimatorForm.ThumbnailsBoxClick(Sender: TObject);
begin
  InvalidateImage(True);
end;

procedure TAnimatorForm.ColorDepthComboChange(Sender: TObject);
begin
  DefaultMappingMethod := TMappingMethod(ColorDepthCombo.ItemIndex);
end;

procedure TAnimatorForm.BackColorButtonClick(Sender: TObject);
begin
  SelectBackColor;
end;

procedure TAnimatorForm.TransColorButtonClick(Sender: TObject);
begin
  SelectTransColor;
end;

procedure TAnimatorForm.LoopChange(Sender: TObject);
begin
  RepeatForever.Enabled := LoopBox.Checked;
  LoopLbl.Enabled := RepeatForever.Enabled;
  RepeatCnt.Enabled := LoopLbl.Enabled;
  if not (FLoading or FUpdating) then begin
    if Sender <> RepeatForever then
      RepeatForever.Checked := RepeatCnt.AsInteger = 0;
    if RepeatForever.Checked then
      FImage.RepeatCount := 0
    else
      FImage.RepeatCount := RepeatCnt.AsInteger;
    FImage.Looping := LoopBox.Checked;
    FModified := True;
  end;
end;

procedure TAnimatorForm.CommentChange(Sender: TObject);
begin
  if not (FLoading or FUpdating) then begin
    if (Sender = FrameComment) and (FImage.FrameIndex >= 0) then
      FImage.Frames[FImage.FrameIndex].Comment := FrameComment.Lines
    else if Sender = TrailingComment then
      FImage.Comment := TrailingComment.Lines;
    FModified := True;
  end;
end;

procedure TAnimatorForm.TopLeftChange(Sender: TObject);
begin
  if not (FLoading or FUpdating) and (FImage.FrameIndex >= 0) then begin
    FImage.Frames[FImage.FrameIndex].Origin := Point(ImageLeft.AsInteger,
      ImageTop.AsInteger);
    FModified := True;
  end;
end;

procedure TAnimatorForm.DelayTimeChange(Sender: TObject);
begin
  if not (FLoading or FUpdating) and (FImage.FrameIndex >= 0) then begin
    FImage.Frames[FImage.FrameIndex].AnimateInterval := DelayTime.AsInteger * 10;
    FModified := True;
  end;
end;

procedure TAnimatorForm.DisposalComboChange(Sender: TObject);
begin
  if not (FLoading or FUpdating) and (FImage.FrameIndex >= 0) then begin
    if DisposalCombo.ItemIndex >= 0 then begin
      FImage.Frames[FImage.FrameIndex].DisposalMethod :=
        TDisposalMethod(DisposalCombo.ItemIndex);
      FModified := True;
    end;
  end;
end;

procedure TAnimatorForm.TransBoxClick(Sender: TObject);
begin
  TransColor.Enabled := TransBox.Checked;
  TransColorLabel.Enabled := TransBox.Checked;
  if not (FLoading or FUpdating) and (FImage.FrameIndex >= 0) then begin
    if not TransBox.Checked then begin
      FImage.Frames[FImage.FrameIndex].TransparentColor := clNone;
      FModified := True;
    end;
  end;
end;

procedure TAnimatorForm.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if (Key = #27) and FLoading then begin
    FAborting := True;
    Key := #0;
  end;
end;

procedure TAnimatorForm.SpeedBarDblClick(Sender: TObject);
begin
  Speedbar.Customize(0);
end;

procedure TAnimatorForm.FlatBtnsClick(Sender: TObject);
begin
  if TCheckBox(Sender).Checked then
    Speedbar.Options := Speedbar.Options + [sbFlatBtns]
  else
    Speedbar.Options := Speedbar.Options - [sbFlatBtns];
end;

procedure TAnimatorForm.AlwaysOnTopClick(Sender: TObject);
begin
  if AlwaysOnTop.Checked then
    SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
      SWP_NOSIZE or SWP_NOACTIVATE)
  else
    SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
      SWP_NOSIZE or SWP_NOACTIVATE);
end;

procedure TAnimatorForm.CheckLabelMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) and not (ssDouble in Shift) then begin
    if TRxLabel(Sender).FocusControl.CanFocus then
      ActiveControl := TRxLabel(Sender).FocusControl;
    if (TRxLabel(Sender).FocusControl is TCheckBox) then
      with TCheckBox(TRxLabel(Sender).FocusControl) do
        if Enabled then Checked := not Checked;
  end;
end;

procedure TAnimatorForm.GrayscaleBtnClick(Sender: TObject);
begin
  GrayscaleImage;
end;

end.