2 Tarih arası periyodik tarih parçalama fonksiyonu

[adelphiforumz]

Selamlar

Başlığı tam olarak nasıl vereceğimi bilemedim kusura bakmayın.

bugün aşağıdaki fonksiyona ihtiyaç duydum belki başkasının da ilerde işine yarar diye buraya ekliyorum.


Bu fonksiyon basitce yaptığı iş ekrandan girilen 2 tarih aralığındaki veriyi belirtilen periyodlarda parçalıyor.
Dinamik bir dizi döndürüyor.

Örneğin 01.02.2025 - 12.03.2025 tarihleri arasında 7 günlük periyod da 
istediğiniz başlangıç ve bitiş tarihlerini size dönüyor.

   

Fonksiyon

type
  TDateRange = record
    Baslangic: TDate;
    Bitis: TDate;
  end;
  TDateRangeArray = TArray<TDateRange>;
. . . . .
. . . . .
function TForm1.fn_TarihArray(const _pBasTarih, _pBitTarih:TDate; _pPeriyod:Integer):TDateRangeArray;
var
 orjIlkTarih, orjSonTarih, dBasTarih, dBitTarih: TDate;
 iGunFarki: Integer;
 bIlk: Boolean;
 iCount : Integer;
begin
 SetLength(Result, 0); // Dinamik dizi oluşturuluyor
 if _pPeriyod <= 0 then exit;
 if _pBitTarih < _pBasTarih then exit;

 // Kullanıcının gönderdiği tarihleri kaydet
 orjIlkTarih := _pBasTarih;
 orjSonTarih := _pBitTarih;
 iGunFarki := DaysBetween(orjIlkTarih, orjSonTarih);

 // İlk ayarlar
 bIlk := True;
 dBasTarih := orjIlkTarih;

 // Eğer gün farkı _pPeriyod dan küçükse, bitiş tarihini son tarihe eşitle
 if iGunFarki >= _pPeriyod then
   dBitTarih := dBasTarih + (_pPeriyod - 1)
 else
   dBitTarih := orjSonTarih;

 // Döngü her durumda en az 1 kez çalışacak
 repeat
   if bIlk then
     bIlk := False
   else
   begin
     // Sonraki periyotlarda _pPeriyod kadar kaydırma yap
     dBasTarih := dBasTarih + _pPeriyod;
     dBitTarih := Min(dBitTarih + _pPeriyod, orjSonTarih);
   end;

   //Eldeki tarihleri diziye doldur
   iCount := Length(Result);
   SetLength(Result, iCount + 1);
   Result[iCount].Baslangic := dBasTarih;
   Result[iCount].Bitis := dBitTarih;

 until dBitTarih >= orjSonTarih;
end;

Kullanım Örneği

procedure TForm1.btnTestClick(Sender: TObject);
var
 DateRangeArray : TArray<TDateRange>;
 i : Integer;
begin
 ListBox1.Items.Clear;
 ListBox1.Items.Add('Başladı : ' + DateToStr(dtFaturaBaslangicTarihi.Date) + ' - ' + DateToStr(dtFaturaBitisTarihi.Date));

 DateRangeArray := fn_TarihArray(dtFaturaBaslangicTarihi.Date, dtFaturaBitisTarihi.Date, SEPeriyod.Value);
 for I := 0 to Length(DateRangeArray) - 1 do
 begin
   ListBox1.Items.Add('Array[' + IntToStr(I) + '] -> ' + DateToStr(DateRangeArray[I].Baslangic) + ' - ' + DateToStr(DateRangeArray[I].Bitis));
 end;

 ListBox1.Items.Add('Bitti : ' + DateToStr(dtFaturaBaslangicTarihi.Date) + ' - ' + DateToStr(dtFaturaBitisTarihi.Date));
end;

[adelphiforumz]

(10-02-2025, Saat: 21:21)ugorkem Adlı Kullanıcıdan Alıntı:

uses dateutils;

procedure gunArtir(basTarihi, bitTarihi: TDateTime; peryot: Integer);
var araTarih: TDateTime;
begin
 while basTarihi + peryot <= bitTarihi do
 begin
     araTarih := basTarihi;
     basTarihi := basTarihi + peryot;
     form3.listbox1.items.add(DateToStr(araTarih)+' - '+ DateToStr(basTarihi));
     basTarihi :=  basTarihi + 1 ;
 end;
end;

procedure TForm3.Button1Click(Sender: TObject); //kullanımı
begin
    gunArtir(DateTimePicker1.Date,DateTimePicker2.Date,7);
end;

---

en basit Array versiyonu 

uses dateutils;


function gunArtir(basTarihi, bitTarihi: TDateTime; peryot: Integer): TArray<string>;
var araTarih: TDateTime;
   sonucList: TStringList;
   i: Integer ;
begin
 sonucList := TStringList.Create;

 try
   while basTarihi + peryot <= bitTarihi do
   begin
     araTarih := basTarihi;
     basTarihi := basTarihi + peryot;
     sonucList.Add( DateToStr(araTarih) + ' - ' + DateToStr(basTarihi) );
     basTarihi :=  basTarihi + 1 ;
   end;

   SetLength(Result, sonucList.Count);
   for i := 0 to sonucList.Count - 1 do
     Result[i] := sonucList[i];

 finally
   sonucList.Free;
 end;
end;

procedure TForm3.Button1Click(Sender: TObject);
var
 tarihArray: TArray<string>;
 i:integer;
begin
   tarihArray := gunArtir(DateTimePicker1.Date,DateTimePicker2.Date,7);
   for i := 0 to High(tarihArray) do
     listbox1.items.add(tarihArray[i]);

end;

Bu kodları test etinmi her ikiside hatalı çalışıyor. tekrardan bir gözden geçir istersen. 
En basitinden 01.02.2025 - 12.02.2025 tarihine 7 eklediğinde senin yazdığın kod da 01.02.2025 - 08.02.2025 yapıyor ve kalıyor 
Benim istediğim ise 01.02.2025 - 07.02.2025, 08.02.2025 - 12.02.2025 olması

[mrmarman]

Çok karmaşık düşünmeden aşağıdaki şekilde bir yapı işinizi görecektir.

type
  tWeek = record
    _Start,
    _End    : TDate;
  end;
  tWeekArray = array of tWeek;

function WeekArray( aBegin, aEnd: TDateTime; aFreq: Integer = 7 ): tWeekArray;
begin

  Finalize(result);

  while (aEnd >= aBegin)
  do
  begin
    setlength( result, Length(result) + 1 );

    result[ high(result) ]._Start := aBegin;

    if (aBegin + (aFreq-1)) <= aEnd
      then
        result[ high(result) ]._End   := aBegin + (aFreq-1)
      else
        result[ high(result) ]._End   := aEnd;

    aBegin := aBegin + aFreq;
  end;
end;

Kullanımı :

procedure TForm1.BitBtn1Click(Sender: TObject);
var
  LBegin, LEnd : TDateTime;

  LWeekArray : tWeekArray;
  i : Integer;
begin
  LBegin  := StrToDateTime( '01.01.2025' );
  LEnd    := StrToDateTime( '22.01.2025' );

  LWeekArray := WeekArray( LBegin, LEnd, 7 );

  for i := Low(LWeekArray) to High(LWeekArray)
    do
      with LWeekArray[i] do
        Memo1.Lines.Add( format('%s - %s : %d', [
            FormatDateTime('DD.MM.YYYY', _Start)
          , FormatDateTime('DD.MM.YYYY', _End)
          , trunc(_End - _Start)+1 ] ) );

  Finalize(LWeekArray);

end;

Kod: (Select All)

01.01.2025 - 07.01.2025 : 7
08.01.2025 - 14.01.2025 : 7
15.01.2025 - 21.01.2025 : 7
22.01.2025 - 22.01.2025 : 1

4 ise

Kod: (Select All)

01.01.2025 - 04.01.2025 : 4
05.01.2025 - 08.01.2025 : 4
09.01.2025 - 12.01.2025 : 4
13.01.2025 - 16.01.2025 : 4
17.01.2025 - 20.01.2025 : 4
21.01.2025 - 22.01.2025 : 2

01.02.2025 - 12.03.2025

Kod: (Select All)

01.02.2025 - 07.02.2025 : 7
08.02.2025 - 14.02.2025 : 7
15.02.2025 - 21.02.2025 : 7
22.02.2025 - 28.02.2025 : 7
01.03.2025 - 07.03.2025 : 7
08.03.2025 - 12.03.2025 : 5

[adelphiforumz]

@mrmarman hocam ellerine sağlı buda farklı bir yol teşekkürler

[adelphiforumz]

@ugorkem basit bir if ile nasıl yazacağımız konusunda bizimle paylaşabilirmisiniz herkes faydalansın mesela.
Kişiden kişiye if basitliği farklıdır. Yazılımda aynı sonuca çıkan bir çok yol olabilir.
Mesela benim göremediğim bir yolu sağ olsun @mrmarman hocamız güzelce örneklemiş
Sizden de bir örnek alabilirmiyiz
Teşekkürler