jvqstrings.pas

East make Tray Icon in delphi

      Exit;
    end;
    Start := Start - L;
  until Start < 1;
end;

function BackPosText(Start: Integer; const FindString, SourceString: string): Integer;
var
  P, L, From: Integer;
begin
  Result := 0;
  L := Length(FindString);
  if (L = 0) or (SourceString = '') or (Start < 2) then
    Exit;
  From := Start - L;
  if From < 1 then
    Exit;
  repeat
    P := PosText(FindString, SourceString, From);
    if P < Start then
    begin
      Result := P;
      Exit;
    end;
    From := From - L;
  until From < 1;
end;

function PosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;
  var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
begin
  Result := False;
  RangeBegin := PosStr(HeadString, SourceString, Start);
  if RangeBegin = 0 then
    Exit;
  RangeEnd := PosStr(TailString, SourceString, RangeBegin + Length(HeadString));
  if RangeEnd = 0 then
    Exit;
  RangeEnd := RangeEnd + Length(TailString) - 1;
  Result := True;
end;

function PosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;
  var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
begin
  Result := False;
  RangeBegin := PosText(HeadString, SourceString, Start);
  if RangeBegin = 0 then
    Exit;
  RangeEnd := PosText(TailString, SourceString, RangeBegin + Length(HeadString));
  if RangeEnd = 0 then
    Exit;
  RangeEnd := RangeEnd + Length(TailString) - 1;
  Result := True;
end;

function InnerTag(Start: Integer; const HeadString, TailString, SourceString: string;
  var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
begin
  Result := False;
  RangeBegin := PosText(HeadString, SourceString, Start);
  if RangeBegin = 0 then
    Exit;
  RangeBegin := RangeBegin + Length(HeadString);
  RangeEnd := PosText(TailString, SourceString, RangeBegin + Length(HeadString));
  if RangeEnd = 0 then
    Exit;
  RangeEnd := RangeEnd - 1;
  Result := True;
end;

function PosTag(Start: Integer; SourceString: string; var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
begin
  Result := PosRangeStr(Start, '<', '>', SourceString, RangeBegin, RangeEnd);
end;

function BackPosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;
  var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
var
  L: Integer;
begin
  // finds a text range backward, e.g. <TD>....</TD> case sensitive
  Result := False;
  L := Length(HeadString);
  if (L = 0) or (Start < 2) then
    Exit;
  Start := Start - L;
  if Start < 1 then
    Exit;
  repeat
    if not PosRangeStr(Start, HeadString, TailString, SourceString, RangeBegin, RangeEnd) then
      Exit;
    if RangeBegin < Start then
    begin
      Result := True;
      Exit;
    end;
    Start := Start - L;
  until Start < 1;
end;

function BackPosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;
  var RangeBegin: Integer; var RangeEnd: Integer): Boolean;
var
  L: Integer;
begin
  // finds a text range backward, e.g. <TD>....</TD> case insensitive
  Result := False;
  L := Length(HeadString);
  if (L = 0) or (Start < 2) then
    Exit;
  Start := Start - L;
  if Start < 1 then
    Exit;
  repeat
    if not PosRangeText(Start, HeadString, TailString, SourceString, RangeBegin, RangeEnd) then
      Exit;
    if RangeBegin < Start then
    begin
      Result := True;
      Exit;
    end;
    Start := Start - L;
  until Start < 1;
end;

function PosNonSpace(Start: Integer; const SourceText: string): Integer;
var
  P, L: Integer;
begin
  Result := 0;
  L := Length(SourceText);
  P := Start;
  if L = 0 then
    Exit;
  while (P < L) and (SourceText[P] = ' ') do
    Inc(P);
  if SourceText[P] <> ' ' then
    Result := P;
end;

function BeginOfAttribute(Start: Integer; const SourceText: string): Integer;
var
  P, L: Integer;
begin
  // parses the beginning of an attribute: space + alpha character
  Result := 0;
  L := Length(SourceText);
  if L = 0 then
    Exit;
  P := PosStr(' ', SourceText, Start);
  if P = 0 then
    Exit;
  P := PosNonSpace(P, SourceText);
  if P = 0 then
    Exit;
  if SourceText[P] in ['a'..'z', 'A'..'Z'] then
    Result := P;
end;

function ParseAttribute(var Start: Integer; const SourceText: string;
  var AName, AValue: string): Boolean;
var
  PN, PV, P: Integer;
begin
  // parses a name="value" attribute from Start; returns 0 when not found or else the position behind the attribute
  Result := False;
  PN := BeginOfAttribute(Start, SourceText);
  if PN = 0 then
    Exit;
  P := PosStr('="', SourceText, PN);
  if P = 0 then
    Exit;
  AName := Trim(Copy(SourceText, PN, P - PN));
  PV := P + 2;
  P := PosStr('"', SourceText, PV);
  if P = 0 then
    Exit;
  AValue := Copy(SourceText, PV, P - PV);
  Start := P + 1;
  Result := True;
end;

procedure ParseAttributes(const SourceText: string; Attributes: TStrings);
var
  Name, Value: string;
  Start: Integer;
begin
  Attributes.BeginUpdate;
  try
    Attributes.Clear;
    Start := 1;
    while ParseAttribute(Start, SourceText, Name, Value) do
      Attributes.Add(Name + '=' + Value);
  finally
    Attributes.EndUpdate;
  end;
end;

function GetToken(var Start: Integer; const SourceText: string): string;
var
  P1, P2: Integer;
begin
  Result := '';
  if Start > Length(SourceText) then
    Exit;
  P1 := PosNonSpace(Start, SourceText);
  if P1 = 0 then
    Exit;
  if SourceText[P1] = '"' then
  begin // quoted token
    P2 := PosStr('"', SourceText, P1 + 1);
    if P2 = 0 then
      Exit;
    Result := Copy(SourceText, P1 + 1, P2 - P1 - 1);
    Start := P2 + 1;
  end
  else
  begin
    P2 := PosStr(' ', SourceText, P1 + 1);
    if P2 = 0 then
      P2 := Length(SourceText) + 1;
    Result := Copy(SourceText, P1, P2 - P1);
    Start := P2;
  end;
end;

function Easter(NYear: Integer): TDateTime;
var
  NMonth, NDay, NMoon, NEpact, NSunday, NGold, NCent, NCorX, NCorZ: Integer;
begin

  { The Golden Number of the year in the 19 year Metonic Cycle }
  NGold := ((NYear mod 19) + 1);

  { Calculate the Century }
  NCent := ((NYear div 100) + 1);

  { No. of Years in which leap year was dropped in order to keep in step
    with the sun }
  NCorX := ((3 * NCent) div 4 - 12);

  { Special Correction to Syncronize Easter with the moon's orbit }
  NCorZ := ((8 * NCent + 5) div 25 - 5);

  { Find Sunday }
  NSunday := ((5 * NYear) div 4 - NCorX - 10);

  { Set Epact (specifies occurance of full moon }
  NEpact := ((11 * NGold + 20 + NCorZ - NCorX) mod 30);

  if (NEpact < 0) then
    NEpact := NEpact + 30;

  if ((NEpact = 25) and (NGold > 11)) or (NEpact = 24) then
    NEpact := NEpact + 1;

  { Find Full Moon }
  NMoon := 44 - NEpact;

  if (NMoon < 21) then
    NMoon := NMoon + 30;

  { Advance to Sunday }
  NMoon := (NMoon + 7 - ((NSunday + NMoon) mod 7));

  if (NMoon > 31) then
  begin
    NMonth := 4;
    NDay := (NMoon - 31);
  end
  else
  begin
    NMonth := 3;
    NDay := NMoon;
  end;

  Result := EncodeDate(NYear, NMonth, NDay);
end;

//gets a datecode. Returns year and weeknumber in format: YYWW

{DayOfWeek function returns Integer 1..7 equivalent to Sunday..Saturday.
ISO 8601 weeks Start with Monday and the first week of a year is the one which
includes the first Thursday - Fiddle takes care of all this}

function GetWeekNumber(Today: TDateTime): string;
const
  Fiddle: array [1..7] of Byte = (6, 7, 8, 9, 10, 4, 5);
var
  Present, StartOfYear: TDateTime;
  FirstDayOfYear, WeekNumber, NumberOfDays: Integer;
  Year, Month, Day: Word;
  YearNumber: string;
begin
  Present := Trunc(Today); //truncate to remove hours, mins and secs
  DecodeDate(Present, Year, Month, Day); //decode to find year
  StartOfYear := EncodeDate(Year, 1, 1); //encode 1st Jan of the year

  //find what day of week 1st Jan is, then add days according to rule
  FirstDayOfYear := Fiddle[DayOfWeek(StartOfYear)];

  //calc number of days since beginning of year + additional according to rule
  NumberOfDays := Trunc(Present - StartOfYear) + FirstDayOfYear;

  //calc number of weeks
  WeekNumber := Trunc(NumberOfDays / 7);

  //Format year, needed to prevent millenium bug and keep the Fluffy Spangle happy
  YearNumber := FormatDateTime('yyyy', Present);

  YearNumber := YearNumber + 'W';

  if WeekNumber < 10 then
    YearNumber := YearNumber + '0'; //add leading zero for week

  //create datecode string
  Result := YearNumber + IntToStr(WeekNumber);

  if WeekNumber = 0 then //recursive call for year begin/end...
    //see if previous year end was week 52 or 53
    Result := GetWeekNumber(EncodeDate(Year - 1, 12, 31))
  else
  if WeekNumber = 53 then
    //if 31st December less than Thursday then must be week 01 of next year
    if DayOfWeek(EncodeDate(Year, 12, 31)) < 5 then
    begin
      YearNumber := FormatDateTime('yyyy', EncodeDate(Year + 1, 1, 1));
      Result := YearNumber + 'W01';
    end;
end;

function RelativePath(const ASrc, ADst: string): string;
var
  Doc, SDoc, ParDoc, Img, SImg, ParImg, Rel: string;
  PDoc, PImg: Integer;
begin
  Doc := ASrc;
  Img := ADst;
  repeat
    PDoc := Pos('\', Doc);
    if PDoc > 0 then
    begin
      ParDoc := Copy(Doc, 1, PDoc);
      ParDoc[Length(ParDoc)] := '/';
      SDoc := SDoc + ParDoc;
      Delete(Doc, 1, PDoc);
    end;
    PImg := Pos('\', Img);
    if PImg > 0 then
    begin
      ParImg := Copy(Img, 1, PImg);
      ParImg[Length(ParImg)] := '/';
      SImg := SImg + ParImg;
      Delete(Img, 1, PImg);
    end;
    if (PDoc > 0) and (PImg > 0) and (SDoc <> SImg) then
      Rel := '../' + Rel + ParImg;
    if (PDoc = 0) and (PImg <> 0) then
    begin
      Rel := Rel + ParImg + Img;
      if Pos(':', Rel) > 0 then
        Rel := '';
      Result := Rel;
      Exit;
    end;
    if (PDoc > 0) and (PImg = 0) then
    begin
      Rel := '../' + Rel;
    end;
  until (PDoc = 0) and (PImg = 0);
  Rel := Rel + ExtractFileName(Img);
  if Pos(':', Rel) > 0 then
    Rel := '';
  Result := Rel;
end;

procedure GetHTMLAnchors(const AFile: string; AList: TStringList);
var
  S, SA: string;
  P1, P2: Integer;
begin
  S := LoadString(AFile);
  P1 := 1;
  repeat
    P1 := PosText('<a name="', S, P1);
    if P1 <> 0 then
    begin
      P2 := PosText('"', S, P1 + 9);
      if P2 <> 0 then
      begin
        SA := Copy(S, P1 + 9, P2 - P1 - 9);
        AList.Add(SA);
        P1 := P2;
      end
      else
        P1 := 0;
    end;
  until P1 = 0;
end;

function UppercaseHTMLTags(const AText: string): string;
var
  P, P2: Integer;
begin
  Result := '';
  P2 := 1;
  repeat
    P := PosStr('<', AText, P2);
    if P > 0 then
    begin
      Result := Result + Copy(AText, P2, P - P2);
      P2 := P;
      if Copy(AText, P, 4) = '<!--' then
      begin
        P := PosStr('-->', AText, P);
        if P > 0 then
        begin
          Result := Result + Copy(AText, P2, P + 3 - P2);
          P2 := P + 3;
        end
        else
          Result := Result + Copy(AText, P2, Length(AText));
      end
      else
      begin
        P := PosStr('>', AText, P);
        if P > 0 then
        begin
          Result := Result + UpperCase(Copy(AText, P2, P - P2 + 1));
          P2 := P + 1;
        end
        else
          Result := Result + Copy(AText, P2, Length(AText));
      end;
    end
    else
    begin
      Result := Result + Copy(AText, P2, Length(AText));
    end;
  until P = 0;
end;

function LowercaseHTMLTags(const AText: string): string;
var
  P, P2: Integer;
begin