{***************************************************************************}
{ TMS IntraWeb Component Pack Pro                                           }
{ for Delphi & C++Builder                                                   }
{                                                                           }
{ written by TMS Software                                                   }
{            copyright © 2015                                               }
{            Email : info@tmssoftware.com                                   }
{            Web : http://www.tmssoftware.com                               }
{                                                                           }
{ The source code is given as is. The author is not responsible             }
{ for any possible damage done due to the use of this code.                 }
{ The component can be freely used in any application. The complete         }
{ source code remains property of the author and may not be distributed,    }
{ published, given or sold in any form as such. No parts of the source      }
{ code can be included in any other component or application without        }
{ written authorization of the author.                                      }
{***************************************************************************}

unit IWDBResponsiveList;

{$I TMSDEFS.INC}

interface

uses
  Windows, Graphics, Controls, Forms, Classes,
  IWControl, IWRenderContext, IWTMSBase,
  IWResponsiveList, DB, JPEG, pngimage;

type
  TTIWDBResponsiveList = class;

  TIWDisplayType = (dtCheckBox, dtImage, dtList, dtText);

  TIWAsyncUpdatedEvent = procedure(Sender: TObject; ItemIndex: integer) of object;
  TIWGetDataTemplateEvent = procedure(Sender: TObject; ItemIndex: integer;
    FieldName: string; var Data: string; var DisplayType: TIWDisplayType) of object;
  TIWGetListDataEvent = procedure(Sender: TObject; FieldName: string;
    var ListItems: TStringList) of object;

  TResponsiveListDataLink = class(TDataLink)
  private
    FResList: TTIWDBResponsiveList;
    Adjusting: Boolean;
  protected
    procedure ActiveChanged; override;
    procedure RecordChanged(Field: TField); override;
  public
    constructor Create(AResList: TTIWDBResponsiveList);
  end;

  TTIWDBResponsiveList = class(TTIWCustomResponsiveList)
  private
    FShowMemoFields: boolean;
    FDataTemplate: TStringList;
    FDataLink: TResponsiveListDataLink;
    FOnGetDataTemplate: TIWGetDataTemplateEvent;
    FOnAsyncUpdated: TIWAsyncUpdatedEvent;
    FOnGetListDataEvent: TIWGetListDataEvent;
    function GetDataSource: TDataSource;
    procedure SetDataSource(const Value: TDataSource);
    procedure SetDataTemplate(const Value: TStringList);
  protected
    function BlobFieldToFile(DBField: TBlobField; var size:tpoint): string;
    property DataLink: TResponsiveListDataLink read FDataLink;
    procedure DoOnItemClick(ItemIndex: integer); override;
    procedure DoUpdateRecord(ItemIndex: integer; FieldNames, FieldValues: TStringList; CallType: integer); override;
    function GetTemplate(): string; override;
    function HTMLDBReplace(s: string; dataset: Tdataset; ItemIndex: integer): string;
    procedure LinkActive(Value: Boolean); virtual;
    procedure UpdateItem();
  public
    procedure IWPaint; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UpdateRecord();
  published
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property DataTemplate: TStringList read FDataTemplate write SetDataTemplate;
    property ShowMemoFields: boolean read FShowMemoFields write FShowMemoFields default false;

    property OnAsyncUpdated: TIWAsyncUpdatedEvent read FOnAsyncUpdated write FOnAsyncUpdated;
    property OnGetDataTemplate: TIWGetDataTemplateEvent read FOnGetDataTemplate write FOnGetDataTemplate;
    property OnGetListDataEvent: TIWGetListDataEvent read FOnGetListDataEvent write FOnGetListDataEvent;
  end;

implementation

uses
  IWApplication, SysUtils;

  { TIWDBResponsiveList }

constructor TTIWDBResponsiveList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDataLink := TResponsiveListDataLink.Create(self);
  FDataTemplate := TStringList.Create;
end;

destructor TTIWDBResponsiveList.Destroy;
begin
  FDataLink.Free;
  FDataTemplate.Free;
  inherited Destroy;
end;

procedure TTIWDBResponsiveList.DoOnItemClick(ItemIndex: integer);
begin
  inherited;
  if Assigned(DataSource) then
  begin
    if (DataSource.DataSet.Active) then
    begin
      DataSource.DataSet.First;
      DataSource.DataSet.MoveBy(ItemIndex);
    end;
  end;
end;

procedure TTIWDBResponsiveList.DoUpdateRecord(ItemIndex: integer; FieldNames,
  FieldValues: TStringList; CallType: integer);
var
  I: Integer;
begin
  if CallType = 0 then
    exit;

  if not Assigned(DataSource) then
    exit;

  if not Assigned(DataSource.DataSet) then
    exit;

  if not (DataSource.DataSet.Active) then
    exit;

  if not (DataSource.DataSet.State in [dsEdit]) then
    exit;

  for I := 0 to FieldNames.Count - 1 do
  begin
    DataSource.DataSet.FieldByName(FieldNames[I]).Text := FieldValues[I];
  end;

  if CallType = 2 then
  begin
    if Assigned(FOnAsyncUpdated) then
      FOnAsyncUpdated(self, ItemIndex);
  end;
end;

function TTIWDBResponsiveList.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

function TTIWDBResponsiveList.GetTemplate: string;
begin
  Result := DataTemplate.Text;
end;

function TTIWDBResponsiveList.BlobFieldToFile(DBField: TBlobField; var size:tpoint): string;
var
  s,ms: TMemoryStream;
  sig:word;
  b: byte;
  Ljpg: TJPEGImage;
  Lpng: TPngImage;
  ABitmap: TBitmap;
  APicture: TPicture;
  oletype: integer;
  oleoffset: integer;
  i: Integer;

begin
  Result := '';
  size.X := 0;
  size.Y := 0;

  if TBlobField(DBField).BlobType = ftGraphic then
  begin
    s := TMemoryStream.Create;
    try
      if (DBField is TGraphicField) then
        (DBField as TGraphicField).SaveToStream(s)
      else
        DBField.SaveToStream(S);

      oletype := -1;
      oleoffset := 0;

      if s.Size > 2 then
      begin
        // find file type
        S.Position := 0;
        S.Read(sig, 2);

        case sig of
        $1C15: // OLE storage
          begin
            i := 0;
            while (i < 512) do
            begin
              S.Read(b, 1);
              inc(i);
              if (b = $FF) then
              begin
                S.Read(b,1);
                inc(i);
                if b = $D8 then
                begin
                  oletype := 1;
                  oleoffset := i;
                  break;
                end;
              end;
              if (b = $47) then
              begin
                S.Read(b,1);
                inc(i);
                if b = $49 then
                begin
                  oletype := 2;
                  oleoffset := i;
                  break;
                end;
              end;
              if (b = ord('B')) then
              begin
                S.Read(b,1);
                inc(i);
                if (b = ord('M')) then
                begin
                  oletype := 0;
                  oleoffset := i;
                  Break;
                end;
              end;

              if (b = $89) then
              begin
                S.Read(b,1);
                inc(i);
                if (b = ord('P')) then
                begin
                  oletype := 3;
                  oleoffset := i;
                  Break;
                end;
              end;
            end;

            S.Seek(oleoffset,0);

            case oletype of
            0:
              begin
                ABitmap := TBitmap.Create;
                ABitmap.LoadFromStream(S);
                if not ABitmap.Empty then
                begin
                  Result := TIWAppCache.GraphicToCacheFile(ABitmap, imgBMP);
                  size.X := ABitmap.Width;
                  size.Y := ABitmap.Height;
                end;
                ABitmap.Free;
              end;
            1:
              begin
                LJPg := TJPEGImage.Create;
                try
                  LJpg.LoadFromStream(S);
                  APicture := TPicture.Create;
                  APicture.Assign(LJpg);

                  if not APicture.Graphic.Empty then
                  begin
                    Result := TIWAppCache.GraphicToCacheFile(APicture.Graphic, imgJPEG);
                    size.X := APicture.Graphic.Width;
                    size.Y := APicture.Graphic.Height;
                  end;
                  APicture.Free;
                finally
                  FreeAndNil(LJpg);
                end;
              end;
            2:
              begin
                ms := TMemoryStream.Create;
                ms.CopyFrom(s,s.Size - s.Position);
                try
                  Result := TIWAppCache.StreamToCacheFile(ms, imgGIF);
                finally
                  ms.Free;
                end;
                ms.Free;
              end;
            3:
              begin
                Lpng := TpngImage.Create;
                try
                  Lpng.LoadFromStream(S);
                  APicture := TPicture.Create;
                  APicture.Assign(Lpng);

                  if not APicture.Graphic.Empty then
                  begin
                    Result := TIWAppCache.GraphicToCacheFile(APicture.Graphic, imgPNG);
                    size.X := APicture.Graphic.Width;
                    size.Y := APicture.Graphic.Height;
                  end;
                  APicture.Free;
                finally
                  FreeAndNil(Lpng);
                end;
              end;
            end;
          end;
        $4947: //gif signature
          begin
            ms := TMemoryStream.Create;
            s.Position := 0;
            ms.LoadFromStream(s);
            try
              Result := TIWAppCache.StreamToCacheFile(ms, imgGIF);
            finally
              ms.Free;
            end;
          end;
        $D8FF: //jpeg signature
          begin
            S.Position := 0;
            LJPg := TJPEGImage.Create;
            try
              LJpg.LoadFromStream(S);
              APicture := TPicture.Create;
              APicture.Assign(LJpg);

              if not APicture.Graphic.Empty then
              begin
                Result := TIWAppCache.GraphicToCacheFile(APicture.Graphic, imgJPEG);
                size.X := APicture.Graphic.Width;
                size.Y := APicture.Graphic.Height;
              end;
              APicture.Free;
            finally
              FreeAndNil(LJpg);
            end;
          end
          else
          begin
            APicture := TPicture.Create;
            APicture.Assign(DBField);
            if not APicture.Graphic.Empty then
            begin
              Result := TIWAppCache.GraphicToCacheFile(APicture.Graphic, imgBMP);

              size.X := APicture.Graphic.Width;
              size.Y := APicture.Graphic.Height;
              APicture.Free;
            end;
          end;
        end;
      end;
    finally
      FreeAndNil(S);
    end;
  end;
end;

function TTIWDBResponsiveList.HTMLDBReplace(s: string; dataset: Tdataset; ItemIndex: integer): string;
var
  beforetag, aftertag, fld, fldvalue, dbfld: string;
  i, j: integer;
  afield: TField;
  size: TPoint;
  dt: TIWDisplayType;
  li: TStringList;
begin
  beforetag := '';
  while Pos('<#', s) > 0 do
  begin
    i := pos('<#', s);
    beforetag := beforetag + copy(s, 1, i - 1); //part prior to the tag
    aftertag := copy(s, i, length(s)); //part after the tag
    j := pos('>', aftertag);
    fld := copy(aftertag, 1, j - 1);
    Delete(fld, 1, 2);
    Delete(s, 1, i + j - 1);

    dbfld := '';
    fldvalue := '';
    if Assigned(DataSet) then
    begin
      if DataSet.Active then
      begin
        afield := DataSet.FieldByName(fld);

        if Assigned(afield) then
        begin
          dt := dtText;

          if Assigned(aField.OnGetText) then
            fldvalue := aField.DisplayText
          else
            fldvalue := aField.AsString;

          if Assigned(FOnGetDataTemplate) then
            FOnGetDataTemplate(self, ItemIndex, fld, fldvalue, dt);

          case dt of
            dtCheckBox:
            begin
              if afield.DataType = ftBoolean then
              begin
                if aField.AsBoolean then
                  dbfld := ' checked'
              end
            end;

            dtImage:
            begin
              if afield.IsBlob then
              begin
                if dt = dtImage then
                begin
                  (aField as TBlobField).BlobType := ftGraphic;
                  dbfld := BlobFieldToFile(aField as TBlobField, size);
                end
                else
                begin
                  if not ShowMemoFields then
                  begin
                    dbfld := '(MEMO)'
                  end
                  else
                    dbfld := fldvalue;
                end;
              end
            end;

            dtList:
            begin
              li := TStringList.Create;

              if Assigned(FOnGetListDataEvent) then
                FOnGetListDataEvent(self, fld, li);

              dbfld := '';
              for I := 0 to li.Count - 1 do
              begin
                dbfld := dbfld + '<option value="' + li.ValueFromIndex[I] + '"';

                if fldvalue = li.ValueFromIndex[I] then
                  dbfld := dbfld + ' selected';

                dbfld := dbfld + '>' + li.Names[I] + '</option>';
              end;

              li.Free;
            end;

            dtText:
            begin
              dbfld := fldvalue;

              if afield.IsBlob then
              begin
                if not ShowMemoFields then
                begin
                  dbfld := '(MEMO)'
                end
              end;
            end;
          end;
        end;
      end
      else
        dbfld := '(' + fld + ')';
    end
    else dbfld := '(' + fld + ')';

    dbfld := StringReplace(dbfld, '''', '&#39;', [rfReplaceAll]);
    dbfld := StringReplace(dbfld, '"', '&#34;', [rfReplaceAll]);
    beforetag := beforetag + dbfld;
  end;

  Result := beforetag + s;
end;

procedure TTIWDBResponsiveList.IWPaint;
begin
  inherited;
end;

procedure TTIWDBResponsiveList.LinkActive(Value: Boolean);
var
  I: Integer;
  li: TIWListItem;
begin
  if not (csDesigning in ComponentState) then
  begin
    if Value then
    begin
      DataSource.DataSet.First;
      I := 0;
      while not DataSource.DataSet.Eof do
      begin
        li := Items.Add;
        li.Text.Text := HTMLDBReplace(DataTemplate.Text, DataSource.DataSet, I);
        DataSource.DataSet.Next;
        I := I + 1;
      end;
      DataSource.DataSet.First;
    end
    else
    begin
      Items.Clear;
    end;
  end;
end;

procedure TTIWDBResponsiveList.SetDataSource(const Value: TDataSource);
begin
  if Value = FDatalink.Datasource then
    Exit;

  FDataLink.DataSource := Value;

  if Value <> nil then
    Value.FreeNotification(Self);
end;

procedure TTIWDBResponsiveList.SetDataTemplate(const Value: TStringList);
begin
  FDataTemplate.Assign(Value);
  Invalidate;
end;

procedure TTIWDBResponsiveList.UpdateRecord;
var
  i, j, ip, qp, calltype: integer;
  s, aftertag, tag, fld, dbfld, fldtype: string;
  afield: TField;
  dbflds: TStringList;
  fldtypes: TStringList;
begin
  if not (Assigned(DataSource)) then
    exit;

  if not (Assigned(DataSource.DataSet)) then
    exit;

  if not (DataSource.DataSet.Active) then
    exit;

  if (ItemIndex < 0) or (ItemIndex >= Items.Count) then
    exit;

  dbflds := TStringList.Create;
  fldtypes := TStringList.Create;
  
  s := LowerCase(Items[ItemIndex].Text.Text);
  while Pos('<input', s) > 0 do
  begin
    dbfld := '';
    fldtype := '';

    i := Pos('<input', s);
    aftertag := copy(s, i, length(s)); //part after the tag
    j := Pos('>', aftertag);
    tag := copy(aftertag, 1, j - 1);
    Delete(s, 1, i + j - 1);

    ip := Pos('id="', tag);
    if ip > 0 then
    begin
      fld := copy(tag, ip + 4, length(tag));
      qp := Pos('"', fld);
      fld := copy(fld, 1, qp - 1);

      afield := DataSource.DataSet.FindField(fld);
      if Assigned(afield) then
        dbfld := fld
      else
        dbfld := '';
    end;

    ip := Pos('type="', tag);
    if ip > 0 then
    begin
      fld := copy(tag, ip + 6, length(tag));
      qp := Pos('"', fld);
      fld := copy(fld, 1, qp - 1);

      if fld = 'text' then
        fldtype := 'value'
      else if fld = 'checkbox' then
        fldtype := 'checked'
      else
        fldtype := '';
    end;

    if (dbfld <> '') and (fldtype <> '') then
    begin
      dbflds.Add(dbfld); 
      fldtypes.Add(fldtype);
    end;    
  end;

  s := LowerCase(Items[ItemIndex].Text.Text);
  while Pos('<textarea', s) > 0 do
  begin
    dbfld := '';
    fldtype := '';
      
    i := Pos('<textarea', s);
    aftertag := copy(s, i, length(s)); //part after the tag
    j := Pos('>', aftertag);
    tag := copy(aftertag, 1, j - 1);
    Delete(s, 1, i + j - 1);

    ip := Pos('id="', tag);
    if ip > 0 then
    begin
      fld := copy(tag, ip + 4, length(tag));
      qp := Pos('"', fld);
      fld := copy(fld, 1, qp - 1);

      afield := DataSource.DataSet.FindField(fld);
      if Assigned(afield) then
      begin
        dbflds.Add(fld);
        fldtypes.Add('value');
      end;
    end;
  end;

  s := LowerCase(Items[ItemIndex].Text.Text);
  while Pos('<select', s) > 0 do
  begin
    dbfld := '';
    fldtype := '';

    i := Pos('<select', s);
    aftertag := copy(s, i, length(s)); //part after the tag
    j := Pos('>', aftertag);
    tag := copy(aftertag, 1, j - 1);
    Delete(s, 1, i + j - 1);

    ip := Pos('id="', tag);
    if ip > 0 then
    begin
      fld := copy(tag, ip + 4, length(tag));
      qp := Pos('"', fld);
      fld := copy(fld, 1, qp - 1);

      afield := DataSource.DataSet.FindField(fld);
      if Assigned(afield) then
      begin
        dbflds.Add(fld);
        fldtypes.Add('value');
      end;
    end;
  end;

  if (dbflds.Count > 0) and (dbflds.Count = fldtypes.Count) then
  begin
    calltype := 2;
    AsyncGetAttributesInt(ItemIndex, dbflds, fldtypes, calltype);
  end;

  dbflds.Free;
  fldtypes.Free;
end;

procedure TTIWDBResponsiveList.UpdateItem;
var
  li: TIWListItem;
  index: integer;
begin
  if Assigned(DataSource.DataSet) then
  begin
    if DataSource.DataSet.Active then
    begin
      index := DataSource.DataSet.RecNo - 1;

      if (index >= 0) and (index < Items.Count) then
      begin
        li := Items[index];
        li.Text.Text := HTMLDBReplace(DataTemplate.Text, DataSource.DataSet, index);
        AsyncItemUpdate(li);
      end;
    end;
  end;
end;

{ TResponsiveListDataLink }

procedure TResponsiveListDataLink.ActiveChanged;
begin
  if not Assigned(FResList) then
    exit;

  FResList.LinkActive(Active);
end;

constructor TResponsiveListDataLink.Create(AResList: TTIWDBResponsiveList);
begin
  inherited Create;
  VisualControl := True;
  FResList := AResList;
  Adjusting := False;
end;

procedure TResponsiveListDataLink.RecordChanged(Field: TField);
begin
  if not Assigned(FResList) then
    exit;

  if not Assigned(Field) then
    exit;

  FResList.UpdateItem;
end;

end.
