jvqstrings.pas

East make Tray Icon in delphi

  Result := '';
  P2 := 1;
  repeat
    P := PosStr('<', AText, P2);
    if P > 0 then
    begin
      Result := Result + Copy(AText, P2, P - P2);
      P2 := P;
      // now check for comments
      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 + LowerCase(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 HexToColor(const AText: string): TColor;
begin
  Result := clBlack;
  if Length(AText) <> 7 then
    Exit;
  if AText[1] <> '#' then
    Exit;
  try
    Result := StringToColor('$' + Copy(AText, 6, 2) + Copy(AText, 4, 2) + Copy(AText, 2, 2));
  except
    Result := clBlack;
  end;
end;

function PosEscaped(Start: Integer; const SourceText, FindText: string; EscapeChar: Char): Integer;
begin
  Result := PosText(FindText, SourceText, Start);
  if Result = 0 then
    Exit;
  if Result = 1 then
    Exit;
  if SourceText[Result - 1] <> EscapeChar then
    Exit;
  repeat
    Result := PosText(FindText, SourceText, Result + 1);
    if Result = 0 then
      Exit;
  until SourceText[Result - 1] <> EscapeChar;
end;

function DeleteEscaped(const SourceText: string; EscapeChar: Char): string;
var
  I: Integer;
  RealLen: Integer;
begin
  RealLen := 0;
  SetLength(Result, Length(SourceText));
  for I := 1 to Length(SourceText) do
    if SourceText[I] <> EscapeChar then
    begin
      Inc(RealLen);
      Result[RealLen] := SourceText[I];
    end;
  SetLength(Result, RealLen);
end;

procedure RecurseDirFiles(const ADir: string; var AFileList: TStringList);
var
  SR: TSearchRec;
  FileAttrs: Integer;
begin
  FileAttrs := faAnyFile or faDirectory;
  if FindFirst(ADir + PathDelim + AllFilePattern, FileAttrs, SR) = 0 then
    while FindNext(SR) = 0 do
      if (SR.Attr and faDirectory) <> 0 then
      begin
        if (SR.Name <> '.') and (SR.Name <> '..') then
          RecurseDirFiles(ADir + PathDelim + SR.Name, AFileList);
      end
      else
        AFileList.Add(ADir + PathDelim + SR.Name);
  FindClose(SR);
end;

procedure RecurseDirProgs(const ADir: string; var AFileList: TStringList);
var
  SR: TSearchRec;
  FileAttrs: Integer;
  {$IFDEF MSWINDOWS}
  E: string;
  {$ENDIF MSWINDOWS}
  {$IFDEF UNIX}
  ST: TStatBuf;
  {$ENDIF UNIX}
begin
  FileAttrs := faAnyFile or faDirectory;
  if FindFirst(ADir + PathDelim + AllFilePattern, FileAttrs, SR) = 0 then
    while FindNext(SR) = 0 do
    begin
      if (SR.Attr and faDirectory) <> 0 then
      begin
        if (SR.Name <> '.') and (SR.Name <> '..') then
          RecurseDirProgs(ADir + PathDelim + SR.Name, AFileList);
      end
      {$IFDEF MSWINDOWS}
      else
      begin
        E := LowerCase(ExtractFileExt(SR.Name));
        if E = '.exe' then
          AFileList.Add(ADir + PathDelim + SR.Name);
      end;
      {$ENDIF MSWINDOWS}
      {$IFDEF UNIX}
      else
      begin
        if stat(PChar(ADir + PathDelim + SR.Name), ST) = 0 then
        begin
          if ST.st_mode and (S_IXUSR or S_IXGRP or S_IXOTH) <> 0 then
            AFileList.Add(ADir + PathDelim + SR.Name);
        end;
      end;
      {$ENDIF UNIX}
    end;
  FindClose(SR);
end;

procedure LoadResourceFile(AFile: string; MemStream: TMemoryStream);
var
  HResInfo: HRSRC;
  HGlobal: THandle;
  Buffer, GoodType: PChar;
  Ext: string;
begin
  Ext := UpperCase(ExtractFileExt(AFile));
  Ext := Copy(Ext, 2, Length(Ext));
  if Ext = 'HTM' then
    Ext := 'HTML';
  GoodType := PChar(Ext);
  AFile := ChangeFileExt(AFile, '');
  HResInfo := FindResource(HInstance, PChar(AFile), GoodType);
  HGlobal := LoadResource(HInstance, HResInfo);
  if HGlobal = 0 then
    raise EResNotFound.CreateResFmt(@RsECannotLoadResource, [AFile]);
  Buffer := LockResource(HGlobal);
  MemStream.Clear;
  MemStream.WriteBuffer(Buffer[0], SizeOfResource(HInstance, HResInfo));
  MemStream.Seek(0, 0);
  UnlockResource(HGlobal);
  FreeResource(HGlobal);
end;

procedure GetNames(AText: string; AList: TStringList);
var
  P: Integer;
  S: string;
begin
  AList.Clear;
  repeat
    AText := Trim(AText);
    P := Pos('="', AText);
    if P > 0 then
    begin
      S := Copy(AText, 1, P - 1);
      AList.Add(S);
      Delete(AText, 1, P + 1);
      P := Pos('"', AText);
      if P > 0 then
        Delete(AText, 1, P);
    end;
  until P = 0;
end;

function NameValuesToXML(const AText: string): string;
var
  AList: TStringList;
  I, C: Integer;
  IName, IValue, Xml: string;
begin
  Result := '';
  if AText = '' then
    Exit;
  AList := TStringList.Create;
  GetNames(AText, AList);
  C := AList.Count;
  if C = 0 then
  begin
    AList.Free;
    Exit
  end;
  Xml := '<accountdata>' + Cr;
  for I := 0 to C - 1 do
  begin
    IName := AList[I];
    IValue := GetValue(AText, IName);
    IValue := StringReplace(IValue, '~~', Cr, [rfReplaceAll]);
    Xml := Xml + '<' + IName + '>' + Cr;
    Xml := Xml + '  ' + IValue + Cr;
    Xml := Xml + '</' + IName + '>' + Cr;
  end;
  Xml := Xml + '</accountdata>' + Cr;
  AList.Free;
  Result := Xml;
end;

function LastPosChar(const FindChar: Char; SourceString: string): Integer;
var
  I: Integer;
begin
  I := Length(SourceString);
  while (I > 0) and (SourceString[I] <> FindChar) do
    Dec(I);
  Result := I;
end;

function PosStr(const FindString, SourceString: string; StartPos: Integer): Integer;
asm
        PUSH    ESI
        PUSH    EDI
        PUSH    EBX
        PUSH    EDX
        TEST    EAX,EAX
        JE      @@qt
        TEST    EDX,EDX
        JE      @@qt0
        MOV     ESI,EAX
        MOV     EDI,EDX
        MOV     EAX,[EAX-4]
        MOV     EDX,[EDX-4]
        DEC     EAX
        SUB     EDX,EAX
        DEC     ECX
        SUB     EDX,ECX
        JNG     @@qt0
        MOV     EBX,EAX
        XCHG    EAX,EDX
        NOP
        ADD     EDI,ECX
        MOV     ECX,EAX
        MOV     AL,BYTE PTR [ESI]
@@lp1:  CMP     AL,BYTE PTR [EDI]
        JE      @@uu
@@fr:   INC     EDI
        DEC     ECX
        JNZ     @@lp1
@@qt0:  XOR     EAX,EAX
        JMP     @@qt
@@ms:   MOV     AL,BYTE PTR [ESI]
        MOV     EBX,EDX
        JMP     @@fr
@@uu:   TEST    EDX,EDX
        JE      @@fd
@@lp2:  MOV     AL,BYTE PTR [ESI+EBX]
        XOR     AL,BYTE PTR [EDI+EBX]
        JNE     @@ms
        DEC     EBX
        JNE     @@lp2
@@fd:   LEA     EAX,[EDI+1]
        SUB     EAX,[ESP]
@@qt:   POP     ECX
        POP     EBX
        POP     EDI
        POP     ESI
end;

function PosText(const FindString, SourceString: string; StartPos: Integer): Integer;
asm
        PUSH    ESI
        PUSH    EDI
        PUSH    EBX
        NOP
        TEST    EAX,EAX
        JE      @@qt
        TEST    EDX,EDX
        JE      @@qt0
        MOV     ESI,EAX
        MOV     EDI,EDX
        PUSH    EDX
        MOV     EAX,[EAX-4]
        MOV     EDX,[EDX-4]
        DEC     EAX
        SUB     EDX,EAX
        DEC     ECX
        PUSH    EAX
        SUB     EDX,ECX
        JNG     @@qtx
        ADD     EDI,ECX
        MOV     ECX,EDX
        MOV     EDX,EAX
        MOVZX   EBX,BYTE PTR [ESI]
        MOV     AL,BYTE PTR [EBX+ToUpperChars]
@@lp1:  MOVZX   EBX,BYTE PTR [EDI]
        CMP     AL,BYTE PTR [EBX+ToUpperChars]
        JE      @@uu
@@fr:   INC     EDI
        DEC     ECX
        JNE     @@lp1
@@qtx:  ADD     ESP,$08
@@qt0:  XOR     EAX,EAX
        JMP     @@qt
@@ms:   MOVZX   EBX,BYTE PTR [ESI]
        MOV     AL,BYTE PTR [EBX+ToUpperChars]
        MOV     EDX,[ESP]
        JMP     @@fr
        NOP
@@uu:   TEST    EDX,EDX
        JE      @@fd
@@lp2:  MOV     BL,BYTE PTR [ESI+EDX]
        MOV     AH,BYTE PTR [EDI+EDX]
        CMP     BL,AH
        JE      @@eq
        MOV     AL,BYTE PTR [EBX+ToUpperChars]
        MOVZX   EBX,AH
        XOR     AL,BYTE PTR [EBX+ToUpperChars]
        JNE     @@ms
@@eq:   DEC     EDX
        JNZ     @@lp2
@@fd:   LEA     EAX,[EDI+1]
        POP     ECX
        SUB     EAX,[ESP]
        POP     ECX
@@qt:   POP     EBX
        POP     EDI
        POP     ESI
end;

function GetBoolValue(const AText, AName: string): Boolean;
begin
  Result := LowerCase(GetValue(AText, AName)) = 'yes';
end;

procedure ListSelect(Src, Dst: TStringList; const AKey, AValue: string);
var
  I: Integer;
begin
  Dst.Clear;
  for I := 0 to Src.Count - 1 do
  begin
    if GetValue(Src[I], AKey) = AValue then
      Dst.Add(Src[I]);
  end;
end;

procedure ListFilter(Src: TStringList; const AKey, AValue: string);
var
  I: Integer;
  Dst: TStringList;
begin
  Dst := TStringList.Create;
  for I := 0 to Src.Count - 1 do
  begin
    if GetValue(Src[I], AKey) = AValue then
      Dst.Add(Src[I]);
  end;
  Src.Assign(Dst);
  Dst.Free;
end;

procedure ListOrderBy(Src: TStringList; const AKey: string; Numeric: Boolean);
var
  I, Index: Integer;
  Lit, Dst: TStringList;
  S: string;
  IValue: Integer;
begin
  if Src.Count < 2 then
    Exit; // nothing to sort
  Lit := TStringList.Create;
  Dst := TStringList.Create;
  for I := 0 to Src.Count - 1 do
  begin
    S := GetValue(Src[I], AKey);
    if Numeric then
    try
      IValue := StrToInt(S);
      // format to 5 decimal places for correct string sorting
      // e.g. 5 becomes 00005
      S := Format('%5.5d', [IValue]);
    except
      // just use the unformatted value
    end;
    Lit.AddObject(S, TObject(I));
  end;
  Lit.Sort;
  for I := 0 to Src.Count - 1 do
  begin
    Index := Integer(Lit.Objects[I]);
    Dst.Add(Src[Index]);
  end;
  Lit.Free;
  Src.Assign(Dst);
  Dst.Free;
end;

// converts a csv list to a tagged string list

procedure CSVToTags(Src, Dst: TStringList);
var
  I, FI, FC: Integer;
  Names: TStringList;
  Rec: TStringList;
  S: string;
begin
  Dst.Clear;
  if Src.Count < 2 then
    Exit;
  Names := TStringList.Create;
  Rec := TStringList.Create;
  try
    Names.CommaText := Src[0];
    FC := Names.Count;
    if FC > 0 then
      for I := 1 to Src.Count - 1 do
      begin
        Rec.CommaText := Src[I];
        S := '';
        for FI := 0 to FC - 1 do
          S := S + Names[FI] + '="' + Rec[FI] + '" ';
        Dst.Add(S);
      end;
  finally
    Rec.Free;
    Names.Free;
  end;
end;

// converts a tagged string list to a csv list
// only fieldnames from the first record are scanned ib the other records