faxfield.bak

将图像转换为传真文件

    finally
      ReleaseDC(FMemo.Handle, Canvas.Handle);
    end;
  finally
    Canvas.Free;
  end;
end;

procedure TTextField.MemoDblClick(Sender: TObject);
var
  NewHeight  : Integer;
  LineCount  : Integer;
  FontDialog : TFontDialog;
begin
  FontDialog := TFontDialog.Create(nil);
  try
    FontDialog.Font := FMemo.Font;
    if FontDialog.Execute then begin
      FMemo.Font := FontDialog.Font;

      {Adjust field height to allow for the new font size}
      LineCount := FMemo.Lines.Count;
      if LineCount < 1 then
        LineCount := 1;
      NewHeight := GetTextHeight * LineCount + 4;
      Constrain(NewHeight, 0, (Parent as TWinControl).Height - Top);
      {If SnapToGrid is enabled, adjust height to fall on a grid line}
      if (Parent as TFaxPanel).SnapToGrid then
        (Parent as TFaxPanel).AdjustHeightToGrid(Top, NewHeight);
      SetBounds(Left, Top, Width, NewHeight);

      if FSelected then begin
        (Parent as TFaxPanel).FieldPositionChange(Left, Top, Width, Height);
        {Set Ruler position marks to the new coordinates}
        if (Parent as TFaxPanel).Owner is TFaxDesigner then
          ((Parent as TFaxPanel).Owner as TFaxDesigner).SetMarkPositions(Left, Top, Width, Height);
      end;
    end;

    if Parent is TFaxPanel then
      (Parent as TFaxPanel).FieldChange(nil);
  finally
    FontDialog.Free;
  end;
end;

procedure TTextField.OnLoadFromFile(Sender: TObject);
var
  OpenDialog : TOpenDialog;
begin
  OpenDialog := TOpenDialog.Create(nil);
  OpenDialog.Filter:='文本文件 (*.txt)|*.TXT|所有文件(*.*)|*.*';
  if OpenDialog.Execute then
  begin
    FMemo.WordWrap:=true;
    FMemo.Lines.LoadFromFile(OpenDialog.FileName);
  end;
end;
function TTextField.GetText : string;
begin
  if Assigned(FMemo) then
    Result := FMemo.Text
  else
    Result := '';
end;

type
  TLocalMemo = class(TMemo);

procedure TTextField.tfEnter(Sender : TObject);
var
  PF : {$IFDEF DELPHI3}TCustomForm{$ELSE}TForm{$ENDIF};
begin
  if (Parent as TFaxPanel).EditMode then begin
    TLocalMemo(FMemo).SetDesigning(False);
  end else begin
    PF := GetParentForm(FMemo);
    PF.DefocusControl(FMemo, False);
    TLocalMemo(FMemo).SetDesigning(True);
  end;
end;

procedure TTextField.tfExit(Sender : TObject);
begin
  TLocalMemo(FMemo).SetDesigning(True);
end;

procedure TTextField.Read(Stream : TStream);
var
  BufSize : LongInt;
  Buffer  : PChar;
  FontRec : TFontRecord;
begin
  {Read BaseField properties}
  inherited Read(Stream);

  {Read the font properties and assign them to TMemo.Font}
  Stream.ReadBuffer(FontRec, SizeOf(FontRec));
  with FMemo.Font, FontRec do begin
    {$IFDEF DELPHI3}
    CharSet := TFontCharSet(frCharSet);
    {$ENDIF}
    Color   := TColor(frColor);
    Height  := frHeight;
    Name    := frName;
    Pitch   := TFontPitch(frPitch);
    Size    := frSize;
    Style   := [];
    if frFontBold then
      Style := Style + [fsBold];
    if frFontItalic then
      Style := Style + [fsItalic];
    if frFontUnderline then
      Style := Style + [fsUnderline];
    if frFontStrikeout then
      Style := Style + [fsStrikeout];
  end;

  {Read the buffer size needed to store the text}
  Stream.ReadBuffer(BufSize, SizeOf(BufSize));

  {If text exists, read it into the buffer and assign it to the TMemo}
  if BufSize > 1 then begin
    GetMem(Buffer, BufSize);
    try
      FillChar(Buffer^, BufSize, 0);
      Stream.ReadBuffer(Buffer^, BufSize);
      FMemo.Text := StrPas(Buffer);
    finally
      FreeMem(Buffer, BufSize);
    end;
  end;
end;

procedure TTextField.Write(Stream : TStream);
var
  FieldType : Byte;
  BufSize   : LongInt;
  Buffer    : PChar;
  FontRec   : TFontRecord;
begin
  {First thing to write out is the field type}
  FieldType := ftTextField;
  Stream.WriteBuffer(FieldType, SizeOf(FieldType));

  {Write out BaseField properties}
  inherited Write(Stream);

  {Initialize FontRec with the font properties and write it out}
  with FMemo.Font, FontRec do begin
    {$IFDEF DELPHI3}
    frCharSet       := Ord(CharSet);
    {$ELSE}
    frCharSet       := 0;
    {$ENDIF}
    frColor         := Color;
    frHeight        := Height;
    frName          := Name;
    frPitch         := Ord(Pitch);
    frSize          := Size;
    frFontBold      := fsBold in Style;
    frFontItalic    := fsItalic in Style;
    frFontUnderline := fsUnderline in Style;
    frFontStrikeout := fsStrikeout in Style;
  end;
  Stream.WriteBuffer(FontRec, SizeOf(FontRec));

  {Find out how big a buffer we need, and write out the buffer size}
  BufSize := FMemo.GetTextLen + 1; {Add one to allow for null character}
  Stream.WriteBuffer(BufSize, SizeOf(BufSize));

  {If the buffer isn't empty, get the memo text and write it out}
  if BufSize > 1 then begin
    GetMem(Buffer, BufSize);
    try
      FillChar(Buffer^, BufSize, 0);
      FMemo.GetTextBuf(Buffer, BufSize);
      Stream.WriteBuffer(Buffer^, BufSize);
    finally
      FreeMem(Buffer, BufSize);
    end;
  end;
end;

{------------------------------ TImageField --------------------------------}

constructor TImageField.Create(AOwner: TComponent);
const
  DefWidth  = 120;
  DefHeight = 120;
begin
  inherited Create(AOwner);
  FImage := TImage.Create(Self);
  with FImage do begin
    Stretch     := True;
    OnMouseDown := bfMouseDown;
    OnMouseUp   := bfMouseUp;
    OnMouseMove := bfMouseMove;
    OnDblClick  := ImageDblClick;
  end;
  SetBounds(Left, Top, DefWidth, DefHeight);
end;  

procedure TImageField.Draw(ACanvas : TCanvas);
var
  AdjustFactor : Double;
begin
  if not FImage.Picture.Bitmap.Empty then begin
    AdjustFactor := (Parent as TFaxPanel).DrawAdjustFactor;
    ACanvas.StretchDraw(Rect(Round(Left * AdjustFactor), Round(Top * AdjustFactor),
                             Round((Left + Width) * AdjustFactor),
                             Round((Top + Height) * AdjustFactor)),
                        FImage.Picture.Bitmap);
  end;
end;

function TImageField.GetPicture : TPicture;
begin
  if Assigned(FImage) then
    Result := FImage.Picture
  else
    Result := nil;
end;

procedure TImageField.ImageDblClick(Sender: TObject);
var
  {$IFDEF DELPHI3}
  PictureDialog : TOpenPictureDialog;
  {$ELSE}
  PictureDialog : TOpenDialog;
  {$ENDIF}
  I             : Integer;
  Ext:String;
  image1:TImage;
  bmp:TBitmap;
begin
  {$IFDEF DELPHI3}
  PictureDialog := TOpenPictureDialog.Create(nil);
  {$ELSE}
  PictureDialog := TOpenDialog.Create(nil);
  {$ENDIF}
  try
    {$IFNDEF DELPHI3}
    PictureDialog.Filter := 'Bitmap files|*.BMP';
    {$ENDIF}
    PictureDialog.Options := [ofHideReadOnly, ofFileMustExist,
                              ofPathMustExist, ofNoChangeDir];
    if PictureDialog.Execute then begin
      Ext:=Uppercase(ExtractFileExt(PictureDialog.FileName));
       if (Ext='.JPG') or (Ext='.JPEG') then
        begin
          image1:=Timage.Create(self);
          image1.picture.loadfromfile(pictureDialog.filename);
          bmp:=TBitmap.create;
          bmp.assign(TJPEGImage(image1.picture.Graphic));
          Fimage.Picture.Bitmap:=bmp;
        end
        else
        FImage.Picture.LoadFromFile(PictureDialog.FileName);
        FImage.Visible := True;
        {Bring all StretchHandles to front so they draw on top of the image}
        for I := Low(bfStretchHandles) to High(bfStretchHandles) do
          bfStretchHandles[I].BringToFront;
        if Parent is TFaxPanel then
          (Parent as TFaxPanel).FieldChange(nil);
    end;
  finally
    PictureDialog.Free;
  end;
end;

procedure TImageField.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  if Assigned(FImage) then
    FImage.SetBounds(ALeft, ATop, AWidth, AHeight);
end;

procedure TImageField.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if Assigned(FImage) then
    FImage.Parent := AParent;
end;

type
  TLocalBitmap = class(TBitmap);

procedure TImageField.Read(Stream : TStream);
var
  IsEmpty : Boolean;
begin
  {Read BaseField properties}
  inherited Read(Stream);

  {Read the IsEmpty value to determine if a bitmap exists}
  Stream.ReadBuffer(IsEmpty, SizeOf(IsEmpty));

  {If we have a bitmap, read it in}
  if not IsEmpty then
    TLocalBitmap(FImage.Picture.Bitmap).ReadData(Stream);
    {ReadData is used because when using SaveToStream/LoadFromStream,
     LoadFromStream assumes that the bitmap occupies the remaining data
     in the stream, therefor no other items can be stored after the bitmap.
     ReadData first reads in the size of the bitmap.
     The WriteData/ReadData routines are protected, but the type-cast using
     a local class alias allow us to access them anyway}
    {FImage.Picture.Bitmap.LoadFromStream(Stream);}
end;

procedure TImageField.Write(Stream : TStream);
var
  FieldType : Byte;
  IsEmpty   : Boolean;
begin
  {First thing to write out is the field type}
  FieldType := ftImageField;
  Stream.WriteBuffer(FieldType, SizeOf(FieldType));

  {Write out BaseField properties}
  inherited Write(Stream);

  {Determine whether a Bitmap is assigned and write this boolean value out}
  IsEmpty := FImage.Picture.Bitmap.Empty;
  Stream.WriteBuffer(IsEmpty, SizeOf(IsEmpty));

  {If we have a bitmap, write it out}
  if not IsEmpty then
    TLocalBitmap(FImage.Picture.Bitmap).WriteData(Stream);
    {WriteData is used because when using SaveToStream/LoadFromStream,
     LoadFromStream assumes that the bitmap occupies the remaining data
     in the stream, therefor no other items can be stored after the bitmap.
     WriteData first writes out the size of the bitmap data.
     The WriteData/ReadData routines are protected, but the type-cast using
     a local class alias allow us to access them anyway}
    {FImage.Picture.Bitmap.SaveToStream(Stream);}
end;


{*** TFaxPanel ***}

constructor TFaxPanel.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FGridSpacingX     := ctGridSpacingX;
  FGridSpacingY     := ctGridSpacingY;
  OnResize          := fpResize;
  OnMouseDown       := fpMouseDown;
  OnMouseUp         := fpMouseUp;
  OnMouseMove       := fpMouseMove;
  fpFieldList       := TList.Create;
end;

destructor TFaxPanel.Destroy;
begin
  {Destroy all items in fpFieldList}
  DeleteAllFields;

  {Now destroy the list itself}
  fpFieldList.Free;
  inherited Destroy;
end;

function TFaxPanel.GetFieldCount : Integer;
begin
  Result := fpFieldList.Count;
end;

function TFaxPanel.GetField(Index : Integer) : TBaseField;
begin
  Result := TBaseField(fpFieldList[Index]);
end;

function TFaxPanel.GetSelectedField : TBaseField;
var
  I      : Integer;
begin
  for I := fpFieldList.Count - 1 downto 0 do begin
    Result := fpFieldList[I];
    if Result.Selected then
      Exit;
  end;
  Result := nil;
end;

procedure TFaxPanel.SetEditMode(Value : Boolean);
var
  I     : Integer;
  Field : TBaseField;
begin
  if Value <> FEditMode then begin