procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
  src: string;
  ms: TMemoryStream;
  si :TCustomsourceItem;
  img  : Timage;
  xList: TList<string>;
  scale:integer;
  d : TCustomDestinationItem;
  Layer :TLayer;
  w,h:Single;
begin
  xList := TList<string>.Create;
  ms := TMemoryStream.Create;
  GetDirect('路徑' + '*.*', False, xList, '.png', True);
  try
    i:=0;
    repeat
      ms.LoadFromFile(xList.Items[i]);
      ms.Position := 0;

      // Source
      si:=ImageList1.Source.Add;
      si.Name:= 'Source'+inttostr(i);
      ms.Seek(0, soFromBeginning);

      scale:=1;
      si.MultiResBitmap.LoadItemFromStream(ms, scale);

      W:=si.MultiResBitmap.Bitmaps[scale].Width;    //Get width from scale
      H:=si.MultiResBitmap.Bitmaps[scale].Height;   //Get height from scale

      d:=imageList1.Destination.Add;
      Layer := d.Layers.Add;
      Layer.SourceRect.Rect := TRectF.Create(0, 0, W , H);   // Create rect W x H
      Layer.Name := si.name;

      Inc(i)
    until
      xList.Count -1 = i

  finally
    xList.Free;
  end;
end;

procedure TForm1.GetDirect(mask: String; isRecursiveSearch_: Boolean;
  var xList: TList<string>; xFilter: string; xGetFullName: Boolean);
var
  sr :TSearchRec;
  tExt :String;
  tDir :String;
  mStr:string;
begin
  try
    tExt := ExtractFileName(mask);
    tDir := ExtractFilePath(mask);

    if tDir[Length(tDir)] <> '\' then tDir := tDir+'\';

    if FindFirst(mask, faAnyFile, sr) = 0 then
    begin
      repeat
          if not (sr.Name = '.') and not (sr.Name ='..')  then
          begin
           //mStr := Format('%s%s', [tDir, sr.Name]);
           //mStr := StringReplace(sr.Name,'Cart_','',[]);
            if Pos(xFilter,sr.Name) > 0 then
            begin
              if xGetFullName then
              begin
                mStr := Format('%s%s', [tDir, sr.Name]);
                xList.Add(mStr);
              end
              else
                xList.Add(sr.Name);
            end;
          end;
      until FindNext(sr) <> 0;
      FindClose(sr);
    end;
  finally

  end;
end;

 

arrow
arrow
    文章標籤
    DelphiXE10
    全站熱搜

    kuraki5336 發表在 痞客邦 留言(0) 人氣()