Ignore:
Timestamp:
Feb 9, 2022, 3:51:26 PM (3 years ago)
Author:
chronos
Message:
  • Added: Support for profile photo as URL.
  • Added: New UContactImage form to show profile photo in bigger size and with URL.
  • Modified: Profile photo image load/save handling moved to separate unit UContactImage.
  • Fixed: Some dynamically created forms were not translated.
  • Added: Remember last used file name for image open/save dialog.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/Forms/UFormContact.pas

    r102 r103  
    88  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
    99  ComCtrls, ActnList, Menus, ExtCtrls, ExtDlgs, Buttons, UContact, LCLIntf,
    10   UFormProperties, DateUtils{$IFDEF LCLGTK2}, Gtk2Globals{$ENDIF};
     10  UFormProperties, DateUtils{$IFDEF LCLGTK2}, Gtk2Globals{$ENDIF}, UContactImage;
    1111
    1212type
    … …  
    1515
    1616  TFormContact = class(TForm)
     17    APhotoSetUrl: TAction;
     18    APhotoShow: TAction;
    1719    APhotoClear: TAction;
    1820    APhotoSave: TAction;
    … …  
    172174    MenuItem2: TMenuItem;
    173175    MenuItem3: TMenuItem;
     176    MenuItem4: TMenuItem;
     177    MenuItem5: TMenuItem;
    174178    OpenPictureDialog1: TOpenPictureDialog;
    175179    PageControlContact: TPageControl;
    … …  
    194198    procedure APhotoLoadExecute(Sender: TObject);
    195199    procedure APhotoSaveExecute(Sender: TObject);
     200    procedure APhotoSetUrlExecute(Sender: TObject);
     201    procedure APhotoShowExecute(Sender: TObject);
    196202    procedure ButtonHomeAddressShowClick(Sender: TObject);
    197203    procedure ButtonNextClick(Sender: TObject);
    198204    procedure ButtonPreviousClick(Sender: TObject);
    199205    procedure ButtonWorkAddressShowClick(Sender: TObject);
     206    procedure EditFullNameChange(Sender: TObject);
    200207    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    201208    procedure FormCreate(Sender: TObject);
    202209    procedure FormDestroy(Sender: TObject);
    203210    procedure FormShow(Sender: TObject);
     211    procedure ImagePhotoClick(Sender: TObject);
    204212    procedure SpeedButtonHomeWebClick(Sender: TObject);
    205213    procedure SpeedButtonAniversaryClick(Sender: TObject);
    … …  
    224232    procedure TabSheetWorkShow(Sender: TObject);
    225233  private
    226     FProfilePhotoActive: Boolean;
    227     FProfilePhotoLoaded: Boolean;
    228     FProfilePhotoModified: Boolean;
    229     procedure SetProfilePhotoActive(AValue: Boolean);
     234    FPhoto: TContactImage;
     235    procedure PhotoChange(Sender: TObject);
    230236  private
    231237    FContact: TContact;
    … …  
    235241    procedure SetContact(AValue: TContact);
    236242    procedure ReloadAllPropertiesTab;
    237     property ProfilePhotoActive: Boolean read FProfilePhotoActive
    238       write SetProfilePhotoActive;
    239243  public
    240244    procedure UpdateInterface;
    … …  
    253257
    254258uses
    255   UCore, UCommon;
     259  UCore, UCommon, UFormImage;
     260
     261resourcestring
     262  SContact = 'Contact';
     263  SPhotoUrl = 'Photo URL';
     264  SPhotoUrlQuery = 'Enter URL for profile photo';
    256265
    257266function DateToISO(Date: TDateTime): string;
    … …  
    274283
    275284{$IF FPC_FULLVERSION<30200}
    276 function TryISOStrToDate(const aString: string; out outDate: TDateTime): Boolean;
     285function TryISOStrToDate(const aString: string; out OutDate: TDateTime): Boolean;
    277286var
    278287  xYear, xMonth, xDay: LongInt;
    … …  
    280289  case Length(aString) of
    281290    8: Result :=
    282           TryStrToInt(Copy(aString, 1, 4), xYear) and
    283           TryStrToInt(Copy(aString, 5, 2), xMonth) and
    284           TryStrToInt(Copy(aString, 7, 2), xDay) and
    285           TryEncodeDate(xYear, xMonth, xDay, outDate);
     291      TryStrToInt(Copy(aString, 1, 4), xYear) and
     292      TryStrToInt(Copy(aString, 5, 2), xMonth) and
     293      TryStrToInt(Copy(aString, 7, 2), xDay) and
     294      TryEncodeDate(xYear, xMonth, xDay, OutDate);
    286295    10: Result :=
    287           TryStrToInt(Copy(aString, 1, 4), xYear) and
    288           TryStrToInt(Copy(aString, 6, 2), xMonth) and
    289           TryStrToInt(Copy(aString, 9, 2), xDay) and
    290           TryEncodeDate(xYear, xMonth, xDay, outDate);
     296      TryStrToInt(Copy(aString, 1, 4), xYear) and
     297      TryStrToInt(Copy(aString, 6, 2), xMonth) and
     298      TryStrToInt(Copy(aString, 9, 2), xDay) and
     299      TryEncodeDate(xYear, xMonth, xDay, OutDate);
    291300  else
    292301    Result := False;
    293302  end;
    294303  if not Result then
    295     outDate := 0;
     304    OutDate := 0;
    296305end;
    297306{$ENDIF}
    … …  
    311320  FormProperties.Show;
    312321
    313   FProfilePhotoLoaded := False;
    314 
    315   // Force to load default profile image
    316   ProfilePhotoActive := True;
    317   ProfilePhotoActive := False;
     322  PhotoChange(nil);
    318323
    319324  PageControlContact.TabIndex := Core.LastContactTabIndex;
    320325  UpdateInterface;
     326end;
     327
     328procedure TFormContact.ImagePhotoClick(Sender: TObject);
     329begin
     330  APhotoShow.Execute;
    321331end;
    322332
    … …  
    417427
    418428procedure TFormContact.TabSheetGeneralHide(Sender: TObject);
    419 var
    420   Photo: string;
    421   PhotoProperty: TContactProperty;
    422   Stream: TMemoryStream;
    423   JpegImage: TJpegImage;
    424   GifImage: TGIFImage;
    425   PngImage: TPortableNetworkGraphic;
    426429begin
    427430  Contact.Fields[cfFullName] := EditFullName.Text;
    … …  
    443446  Contact.Fields[cfCategories] := EditCategories.Text;
    444447
    445   // Photo
    446   if FProfilePhotoModified then begin
    447   if ProfilePhotoActive then begin
    448     PhotoProperty := Contact.GetProperty(cfPhoto);
    449     if not Assigned(PhotoProperty) then begin
    450       PhotoProperty := TContactProperty.Create;
    451       PhotoProperty.Name := 'PHOTO';
    452       PhotoProperty.Attributes.DelimitedText := 'JPEG';
    453       Contact.Properties.Add(PhotoProperty);
    454     end;
    455     PhotoProperty.Encoding := 'BASE64';
    456     Stream := TMemoryStream.Create;
    457     try
    458       if PhotoProperty.Attributes.IndexOf('JPEG') <> -1 then begin
    459         JpegImage := TJPEGImage.Create;
    460         try
    461           try
    462             JpegImage.SetSize(ImagePhoto.Picture.Bitmap.Width, ImagePhoto.Picture.Bitmap.Height);
    463             JpegImage.Canvas.Draw(0, 0, ImagePhoto.Picture.Bitmap);
    464             JpegImage.SaveToStream(Stream);
    465           except
    466           end;
    467         finally
    468           JpegImage.Free;
    469         end;
    470       end else
    471       if PhotoProperty.Attributes.IndexOf('PNG') <> -1 then begin
    472         PngImage := TPortableNetworkGraphic.Create;
    473         try
    474           try
    475             PngImage.SetSize(ImagePhoto.Picture.Bitmap.Width, ImagePhoto.Picture.Bitmap.Height);
    476             PngImage.Canvas.Draw(0, 0, ImagePhoto.Picture.Bitmap);
    477             PngImage.SaveToStream(Stream);
    478           except
    479           end;
    480         finally
    481           PngImage.Free;
    482         end;
    483       end else
    484       if PhotoProperty.Attributes.IndexOf('GIF') <> -1 then begin
    485         GifImage := TGIFImage.Create;
    486         try
    487           try
    488             GifImage.SetSize(ImagePhoto.Picture.Bitmap.Width, ImagePhoto.Picture.Bitmap.Height);
    489             GifImage.Canvas.Draw(0, 0, ImagePhoto.Picture.Bitmap);
    490             GifImage.SaveToStream(Stream);
    491           except
    492           end;
    493         finally
    494           GifImage.Free;
    495         end;
    496       end else begin
    497         try
    498           ImagePhoto.Picture.SaveToStream(Stream);
    499         except
    500         end;
    501       end;
    502 
    503       SetLength(Photo, Stream.Size);
    504       Stream.Position := 0;
    505       Stream.Read(Photo[1], Length(Photo));
    506       Contact.Fields[cfPhoto] := Photo;
    507     finally
    508       Stream.Free;
    509     end;
    510   end else begin
    511     PhotoProperty := Contact.GetProperty(cfPhoto);
    512     if Assigned(PhotoProperty) then
    513        Contact.Properties.Remove(PhotoProperty);
    514   end;
    515     FProfilePhotoModified := False;
    516   end;
     448  FPhoto.Contact := Contact;
     449  FPhoto.Save;
    517450
    518451  ReloadAllPropertiesTab;
    … …  
    520453
    521454procedure TFormContact.TabSheetGeneralShow(Sender: TObject);
    522 var
    523   Photo: string;
    524   JpegImage: TJpegImage;
    525   PngImage: TPortableNetworkGraphic;
    526   GifImage: TGIFImage;
    527   Stream: TMemoryStream;
    528   PhotoProperty: TContactProperty;
    529455begin
    530456  EditFullName.Text := Contact.Fields[cfFullName];
    … …  
    546472  EditCategories.Text := Contact.Fields[cfCategories];
    547473
    548   // Photo
    549   PhotoProperty := Contact.GetProperty(cfPhoto);
    550   if not FProfilePhotoLoaded then begin
    551   if Assigned(PhotoProperty) then begin
    552     FProfilePhotoLoaded := True;
    553     FProfilePhotoModified := True;
    554     Photo := Contact.Fields[cfPhoto];
    555     if (Photo <> '') and (PhotoProperty.Encoding <> '') then begin
    556       Stream := TMemoryStream.Create;
    557       try
    558         Stream.Write(Photo[1], Length(Photo));
    559         Stream.Position := 0;
    560         if (PhotoProperty.Attributes.IndexOf('JPEG') <> -1) or
    561         (PhotoProperty.Attributes.IndexOf('jpeg') <> -1) then begin
    562           JpegImage := TJPEGImage.Create;
    563           try
    564             try
    565               JpegImage.LoadFromStream(Stream);
    566               with ImagePhoto.Picture.Bitmap do begin
    567                 PixelFormat := pf24bit;
    568                 SetSize(JpegImage.Width, JpegImage.Height);
    569                 Canvas.Draw(0, 0, JpegImage);
    570               end;
    571               ProfilePhotoActive := True;
    572             except
    573               ProfilePhotoActive := False;
    574             end;
    575           finally
    576             JpegImage.Free;
    577           end;
    578         end else
    579         if (PhotoProperty.Attributes.IndexOf('PNG') <> -1) or
    580         (PhotoProperty.Attributes.IndexOf('png') <> -1) then begin
    581           PngImage := TPortableNetworkGraphic.Create;
    582           try
    583             try
    584               PngImage.LoadFromStream(Stream);
    585               with ImagePhoto.Picture.Bitmap do begin
    586                 PixelFormat := pf24bit;
    587                 SetSize(PngImage.Width, PngImage.Height);
    588                 Canvas.Draw(0, 0, PngImage);
    589               end;
    590               ProfilePhotoActive := True;
    591             except
    592               ProfilePhotoActive := False;
    593             end;
    594           finally
    595             PngImage.Free;
    596           end;
    597         end else
    598         if (PhotoProperty.Attributes.IndexOf('GIF') <> -1) or
    599         (PhotoProperty.Attributes.IndexOf('gif') <> -1) then begin
    600           GifImage := TGIFImage.Create;
    601           try
    602             try
    603               GifImage.LoadFromStream(Stream);
    604               with ImagePhoto.Picture.Bitmap do begin
    605                 PixelFormat := pf24bit;
    606                 SetSize(GifImage.Width, GifImage.Height);
    607                 Canvas.Draw(0, 0, GifImage);
    608               end;
    609               ProfilePhotoActive := True;
    610             except
    611               ProfilePhotoActive := False;
    612             end;
    613           finally
    614             GifImage.Free;
    615           end;
    616         end else begin
    617           try
    618             ImagePhoto.Picture.LoadFromStream(Stream);
    619             ProfilePhotoActive := True;
    620           except
    621             ProfilePhotoActive := False;
    622           end;
    623         end;
    624       finally
    625         Stream.Free;
    626       end;
    627     end else ProfilePhotoActive := False;
    628   end else ProfilePhotoActive := False;
    629   end;
     474  FPhoto.Contact := Contact;
     475  FPhoto.Load;
    630476end;
    631477
    … …  
    750596end;
    751597
    752 procedure TFormContact.SetProfilePhotoActive(AValue: Boolean);
    753 begin
    754   if FProfilePhotoActive = AValue then Exit;
    755   FProfilePhotoActive := AValue;
    756   if not FProfilePhotoActive then begin
    757     ImagePhoto.Picture.Assign(Core.GetProfileImage.Picture);
    758   end;
     598procedure TFormContact.PhotoChange(Sender: TObject);
     599begin
     600  if FPhoto.Used and (FPhoto.Url = '') then
     601    ImagePhoto.Picture.Bitmap.Assign(FPhoto.Bitmap)
     602    else ImagePhoto.Picture.Assign(Core.GetProfileImage.Picture);
    759603  UpdateInterface;
    760604end;
    … …  
    791635procedure TFormContact.APhotoLoadExecute(Sender: TObject);
    792636begin
     637  OpenPictureDialog1.FileName := Core.LastPhotoFileName;
    793638  if OpenPictureDialog1.Execute then begin
    794     ImagePhoto.Picture.LoadFromFile(OpenPictureDialog1.FileName);
    795     FProfilePhotoModified := True;
    796     FProfilePhotoLoaded := True;
    797     ProfilePhotoActive := True;
     639    FPhoto.LoadFromFile(OpenPictureDialog1.FileName);
     640    Core.LastPhotoFileName := OpenPictureDialog1.FileName;
    798641  end;
    799642end;
    … …  
    801644procedure TFormContact.APhotoClearExecute(Sender: TObject);
    802645begin
    803   FProfilePhotoModified := True;
    804   ProfilePhotoActive := False;
     646  FPhoto.Clear;
    805647end;
    806648
    807649procedure TFormContact.APhotoSaveExecute(Sender: TObject);
    808650begin
     651  SavePictureDialog1.FileName := Core.LastPhotoFileName;
    809652  if SavePictureDialog1.Execute then begin
    810653    ImagePhoto.Picture.SaveToFile(SavePictureDialog1.FileName);
     654    Core.LastPhotoFileName := SavePictureDialog1.FileName;
     655  end;
     656end;
     657
     658procedure TFormContact.APhotoSetUrlExecute(Sender: TObject);
     659begin
     660  FPhoto.Url := InputBox(SPhotoUrl, SPhotoUrlQuery, FPhoto.Url);
     661end;
     662
     663procedure TFormContact.APhotoShowExecute(Sender: TObject);
     664begin
     665  with TFormImage.Create(nil) do
     666  try
     667    Image.Assign(FPhoto);
     668    if ShowModal = mrOK then begin
     669      FPhoto.Assign(Image);
     670      UpdateInterface;
     671    end;
     672  finally
     673    Free;
    811674  end;
    812675end;
    … …  
    844707end;
    845708
     709procedure TFormContact.EditFullNameChange(Sender: TObject);
     710begin
     711  UpdateInterface;
     712end;
     713
    846714procedure TFormContact.FormCreate(Sender: TObject);
    847715begin
    … …  
    850718  FContact := nil;
    851719  FormProperties := TFormProperties.Create(nil);
     720  FPhoto := TContactImage.Create;
     721  FPhoto.FieldIndex := cfPhoto;
     722  FPhoto.OnChange := PhotoChange;
    852723end;
    853724
    854725procedure TFormContact.FormDestroy(Sender: TObject);
    855726begin
     727  FreeAndNil(FPhoto);
    856728  FreeAndNil(FormProperties);
    857729end;
    … …  
    859731procedure TFormContact.UpdateInterface;
    860732begin
    861   APhotoSave.Enabled := ProfilePhotoActive;
    862   APhotoClear.Enabled := ProfilePhotoActive;
     733  Caption := EditFullName.Text + ' - ' + SContact;
     734  APhotoSave.Enabled := FPhoto.Used;
     735  APhotoClear.Enabled := FPhoto.Used;
    863736  //ButtonNext.Enabled := Assigned(FOnGetNext) and Assigned(FOnGetNext(Contact));
    864737  //ButtonPrevious.Enabled := Assigned(FOnGetPrevious) and Assigned(FOnGetPrevious(Contact));
Note: See TracChangeset for help on using the changeset viewer.