fcimager.pas

一套及时通讯的原码

        FWorkBitmap.SetSize(fcMax(Picture.Width, Picture.Height), fcMax(Picture.Height, Picture.Width))
     else
        FWorkBitmap.SetSize(Picture.Width, Picture.Height)
  end;
  UpdateWorkBitmap;
  UpdateAutoSize;
end;

procedure TfcCustomImager.UpdateAutoSize;
begin
  if FAutoSize and not PictureEmpty and not (csLoading in ComponentState) and (Align = alNone) then
  begin
    UpdatingAutosize := True;
    if (Width <> Picture.Width) or (Height <> Picture.Height) then
      SetBounds(Left, Top, Picture.Width, Picture.Height);
    UpdatingAutosize := False;
  end;
end;

procedure TfcCustomImager.UpdateWorkBitmap;
begin
  if not PictureEmpty and not (csLoading in ComponentState) then
  begin
    if FWorkBitmap.Empty then Resized;
    BitmapOptions.Changed;
  end;
end;

procedure TfcCustomImager.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;

procedure TfcCustomImager.SetPreProcess(Value: Boolean);
begin
  if FPreProcess <> Value then
  begin
    FPreProcess := Value;
    Resized;
  end;
end;

procedure TfcCustomImager.SetTransparent(Value: Boolean);
begin
  FTransparent:=Value;
  if not PictureEmpty then Picture.Graphic.Transparent := Value;
  Invalidate;
end;

procedure TfcCustomImager.SetTransparentColor(Value: TColor);
begin
  WorkBitmap.TransparentColor := Value;
  UpdateWorkBitmap;
  Invalidate;
  ColorToString(clNone);
end;

function TfcCustomImager.GetRespectPalette;
begin
  result:= FRespectPalette;
end;

function TfcCustomImager.GetSmoothStretching: Boolean;
begin
  result := WorkBitmap.SmoothStretching;
end;

function TfcCustomImager.GetTransparent: Boolean;
begin
  result:= FTransparent;
//  result := False;                   
//  if not PictureEmpty then result := Picture.Graphic.Transparent;
end;

function TfcCustomImager.GetTransparentColor: TColor;
begin
  result := WorkBitmap.TransparentColor;
end;

procedure TfcCustomImager.SetAutoSize(Value: Boolean);
begin
  if FAutoSize <> Value then
  begin
    FAutoSize := Value;
    UpdateAutoSize;
  end;
end;
{
procedure TfcCustomImager.SetBitmap(Value: TfcBitmap);
begin
  FBitmap.Assign(Value);
end;
}

function TfcCustomImager.PictureEmpty: Boolean;
begin
  result := (FPicture=Nil) or (FPicture.Graphic = nil) or (FPicture.Graphic.Empty);
end;

procedure TfcCustomImager.Invalidate;
var r: TRect;
begin
  if InSetBounds then exit;
  r := BoundsRect;
  if Parent <> nil then InvalidateRect(Parent.Handle, @r, True);
end;

procedure TfcCustomImager.RegisterChanges(ChangeLink: TfcChangeLink);
begin
  FChangeLinks.Add(ChangeLink);
end;

procedure TfcCustomImager.UnRegisterChanges(ChangeLink: TfcChangeLink);
begin
  FChangeLinks.Remove(ChangeLink);
end;

procedure TfcCustomImager.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var SizeChanged: Boolean;
    OldControlStyle: TControlStyle;
begin
  SizeChanged := (AWidth <> Width) or (AHeight <> Height);
  if SizeChanged and not UpdatingAutosize then begin
     InSetBounds:= True; { RSW - Don't erase background when resizing }
     { 5/7/99 - Setting parent to opaque so it doesn't clear background.
       This allows imager to not flicker when resizing imager }
     if Parent<>nil then
     begin
        OldControlStyle:= Parent.ControlStyle;
        Parent.ControlStyle:= Parent.ControlStyle + [csOpaque];
     end;
     inherited;
     if Parent<>nil then Parent.ControlStyle:= OldControlStyle;
     if Visible then Update;
     Resized;
     InSetBounds:= False;
  end
  else inherited;
end;

procedure TfcCustomImager.SetRespectPalette(Value: Boolean);
begin
  FRespectPalette:= Value;
  WorkBitmap.RespectPalette := Value;
  if value then
     if (BitmapOptions.Color<>clNone) or (BitmapOptions.TintColor<>clNone) then
        WorkBitmap.RespectPalette:= False;

  Invalidate;
end;

procedure TfcCustomImager.SetFocus;
begin
   inherited;
   if FWinControl <> nil then
     FWinControl.SetFocus;
end;

procedure TfcCustomImager.SetShowFocusRect(Value: Boolean);
begin
  if Value <> FShowFocusRect then
     FShowFocusRect := Value;
end;

procedure TfcCustomImager.SetSmoothStretching(Value: Boolean);
begin
  WorkBitmap.SmoothStretching := Value;
  UpdateWorkBitmap;
  Invalidate;
end;

procedure TfcCustomImager.Paint;
var r:TRect;
begin
  inherited;
  if csDestroying in ComponentState then exit;

  if FWorkBitmap.Empty and not PictureEmpty then
  begin
    UpdateWorkBitmap;
    Exit;
  end;

  if (csDesigning in ComponentState) and FWorkBitmap.Empty then with Canvas do
  begin
    Pen.Style := psDash;
    Pen.Color := clBlack;
    Brush.Color := clWhite;
    Rectangle(0, 0, Width, Height);
    Exit;
  end;
  if FWorkBitmap.Empty then Exit;

  try
    with GetDrawRect do
      if PreProcess then
        case DrawStyle of
          dsNormal: Canvas.Draw(Left, Top, FWorkBitmap);
          dsCenter: Canvas.Draw(Left, Top, FWorkBitmap);
          dsTile: FWorkBitmap.TileDraw(Canvas, Rect(Left, Top, Right, Bottom));
          dsStretch: Canvas.StretchDraw(Rect(Left, Top, Right, Bottom), FWorkBitmap);
          dsProportional,dsproportionalCenter: Canvas.StretchDraw(Rect(Left, Top, Right, Bottom), FWorkBitmap);
        end
      else Canvas.Draw(Left, Top, FWorkBitmap);
  finally
{    if Transparent then fcTransparentDraw(Canvas, Rect(0, 0, Width, Height), DrawBitmap, DrawBitmap.Canvas.Pixels[0, 0])
    else Canvas.Draw(0, 0, DrawBitmap);}
  end;

  if Focused and ShowFocusRect then begin
    r:= ClientRect;
    Canvas.DrawFocusRect(r);
  end;

end;


(*procedure TfcCustomImager.ParentMessages(var Message: TMessage; var ProcessMessage: Boolean);
var s: TfcCustomImager;
begin
  if csDestroying in ComponentState then exit;

  if not PictureEmpty and ((not EraseBackground) or InSetBounds) and
{     not (csDesigning in ComponentState) and}  { 4/27/99 - Comment out - RSW }
     (Message.Msg = WM_ERASEBKGND) then//and not (DrawStyle in [dsNormal, dsProportional]) {and (Align = alClient) }then { 3/19/99 - Comment out alClient to prevent flicker of form}
  begin
    with TWMEraseBkGnd(Message) do
    begin
      Result := 1;
      ProcessMessage := False;
    end;
  end
end;
*)
procedure TfcCustomImager.Loaded;
begin
  inherited;
  UpdateAutoSize;
  FBitmapOptions.Changed;
end;

procedure TfcCustomImager.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
end;

procedure TfcCustomImager.CutToClipboard;
begin
  if Picture.Graphic <> nil then
  begin
    CopyToClipboard;
    Picture.Graphic := nil;
  end;
end;

procedure TfcCustomImager.CopyToClipboard;
var tempBitmap: TBitmap;
begin
   tempBitmap:= TBitmap.create;
   WorkBitmap.SaveToBitmap(tempBitmap);
   Clipboard.Assign(tempBitmap);
   tempBitmap.Free;
end;

procedure TfcCustomImager.WndProc(var Message: TMessage);
begin
  inherited;
end;

type
 TfcImagerWinControl = class(TWinControl)
 private
    Imager: TfcCustomImager;
 protected
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
 public
    constructor Create(AOwner: TComponent); override;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
 end;

constructor TfcImagerWinControl.Create(AOwner: TComponent);
begin
   inherited;
   ControlStyle := ControlStyle + [csReplicatable];
   Imager:= AOwner as TfcCustomImager;
end;

procedure TfcImagerWinControl.CMEnter(var Message: TCMEnter);
begin
  Imager.DoEnter;
end;

procedure TfcImagerWinControl.CMExit(var Message: TCMExit);
begin
  Imager.DoExit;
end;

procedure TfcImagerWinControl.KeyDown(var Key: Word; Shift: TShiftState);
begin
   inherited KeyDown(Key, Shift);
   Imager.KeyDown(Key, Shift);
end;

procedure TfcImagerWinControl.KeyUp(var Key: Word; Shift: TShiftState);
begin
   inherited KeyUp(Key, Shift);
   Imager.KeyUp(Key, Shift);
end;

procedure TfcImagerWinControl.KeyPress(var Key: Char);
begin
   inherited KeyPress(Key);
   Imager.KeyPress(Key);
end;

constructor TfcDBImager.Create(AOwner: TComponent);
begin
   inherited;
   ControlStyle := ControlStyle + [csReplicatable];
   FPictureType := fcptBitmap;
   FBorderStyle := bsSingle;
   FAutoDisplay:=True;
   FDataLink := TFieldDataLink.Create;
   FDataLink.Control := Self;
   FDataLink.OnDataChange := DataChange;
   FDataLink.OnUpdateData := UpdateData;
end;

destructor TfcDBImager.Destroy;
begin
   FDataLink.Free;
   FDataLink:=nil;
   inherited Destroy;
end;

procedure TfcDBImager.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FDataLink <> nil) and
    (AComponent = DataSource) then DataSource := nil;
end;

procedure TfcDBImager.LoadPicture;
var j:TGraphic;
  ms:Tmemorystream;
  w:TMetaFile;
  ic:TfcIcon;
  pt:TfcImagerPictureType;
  gclassname:string;
begin
   if FDataLink.Field = nil then begin
      Picture.Assign(nil);
//      WorkBitmap.FreeMemoryImage;
      WorkBitmap.Clear;
      exit;
   end;

  if not FPictureLoaded and (not Assigned(FDataLink.Field) or
    FDataLink.Field.IsBlob) then
  begin
    pt:=PictureType;
    gclassname:='';
    DoCalcPictureType(pt,gclassname);
    case pt of
      fcptBitmap: begin
         try
           Picture.Assign(FDataLink.Field);
         except
         end;
        end;
      fcptJpg:
        begin
//            RegisterClass(TJpegImage);
//            j:=tjpegimage.create;
            if gclassname = '' then gclassname := 'TJPEGImage';
            if (GetClass(gclassname) = nil) then exit;
            j:= TGraphic(TGraphicClass(GetClass(gclassname)).create);
            ms:=tmemorystream.create;
            try
              tblobfield(FDataLink.Field).savetostream(ms);
              ms.seek(sofrombeginning,0);

              with j do begin
{                pixelformat := jf24bit;
                scale := jsfullsize;
                grayscale := False;
                performance := jpbestquality;
                progressivedisplay := True;
                progressiveencoding := True;}
                LoadFromStream(ms);
              end;
              Picture.assign(j);
            finally
               j.free;
               ms.free;
            end;
          end;
      fcptIcon:
        begin
          ic:=tfcIcon.create;
          ms:=tmemorystream.create;
          try
            tblobfield(FDataLink.Field).savetostream(ms);
            ms.seek(sofrombeginning,0);
            with ic do begin
              loadfromstream(ms);
            end;
            Picture.Assign(ic);
          finally
             ic.free;
             ms.free;
          end;
        end;
      fcptMetafile:
        begin
          w:=TMetaFile.create;
          ms:=tmemorystream.create;
          try
            tblobfield(FDataLink.Field).savetostream(ms);
            Picture.assign(w);
            ms.seek(sofrombeginning,0);
            with w do begin
              Picture.Metafile.loadfromstream(ms);
            end;
          finally
             w.free;
             ms.free;
          end;
        end;
      end;

     if Picture.Graphic<>nil then
        Picture.Graphic.Transparent:=Transparent;
    Invalidate;
  end;
end;

procedure TfcDBImager.DataChange(Sender: TObject);
begin
  Picture.Graphic := nil;
  FWorkBitmap.Clear;